view release on metacpan or  search on metacpan

lib/Assert/Conditional.pm  view on Meta::CPAN

sub  assert_untied_globref                    (  $                ) ;
sub  assert_untied_hash                       ( \%                ) ;
sub  assert_untied_hashref                    (  $                ) ;
sub  assert_untied_referent                   (  $                ) ;
sub  assert_untied_scalar                     ( \$                ) ;
sub  assert_untied_scalarref                  (  $                ) ;
sub  assert_uppercased                        (  $                ) ;
sub  assert_void_context                      (                   ) ;
sub  assert_whole_number                      (  $                ) ;
sub  assert_wide_characters                   (  $                ) ;
sub  assert_zero                              (  $                ) ;
############################################################

sub import {
    my ($package, @conditional_imports) = @_;
    my @normal_imports = $package->_strip_import_conditions(@conditional_imports);
    if    ($Assert_Never)  { $package->SUPER::import(@normal_imports, -if => 0) }
    elsif ($Assert_Always) { $package->SUPER::import(@normal_imports, -if => 1) }
    else                   { $package->SUPER::import(@conditional_imports     ) }
    $package->_reimport_nulled_code_protos();
}

# This is just pretty extreme, but it's also about the only way to
# make the Exporter shut up about things we sometimes need to do in
# this module.
#
# Well, not quite the only way: there's always local *SIG. :)
#
# Otherwise it dribbles all over your screen when you try more than one
# import, like importing a set and then reneging on a few of them.
# 
# Newer versions of Carp appear not to need these heroics.

sub export_to_level {
    my($package, $level, @export_args) = @_;

    state $old_carp = \&Carp::carp;
    state $filters = [
        qr/^Constant subroutine \S+ redefined/,
        qr/^Subroutine \S+ redefined/,
        qr/^Prototype mismatch:/,
    ];

    no warnings "redefine";
    local *Carp::carp = sub {
        my($text) = @_;
        $text =~ $_ && return for @$filters;
        local $Carp::CarpInternal{"Exporter::Heavy"} = 1;
        $old_carp->($text);
    };
    $package->SUPER::export_to_level($level+2, @export_args);
}

# You have to do this if you have asserts that take a code
# ref as their first argument and people want to use those
# without parentheses. That's because the constant subroutine
# that gets installed necessarily no longer has the prototype
# needed to support a code ref in the dative slot syntactically.
sub _reimport_nulled_code_protos {
    my($my_pack) = @_;
    my $his_pack = caller(1);

    no strict "refs";

    for my $export (@{$my_pack . "::EXPORT_OK"}) {
        my $real_proto = prototype($my_pack . "::$export");
        $real_proto && $real_proto =~ /^\s*&/           || next;
        my $his_func = $his_pack . "::$export";
        defined &$his_func                              || next;
        prototype($his_func)                            && next;
        eval qq{
            no warnings qw(prototype redefine);
            package $his_pack;
            sub $export ($real_proto) { 0 }
            1;
        } || panic "eval failed";
    }
}

# Remove the trailing -if/-unless from the conditional
# import list.
sub _strip_import_conditions {
    my($package, @args) = @_;
    my @export_args;
    while (@args && ($args[0] || '') !~ /^-(?:if|unless)$/) {
        push @export_args, shift @args;
    }
    return @export_args;
}

################################################################
# The following attribute handler handler for subs saves
# us a lot of bookkeeping trouble by letting us declare
# which export tag groups a particular assert belongs to
# at the point of declaration where it belongs, and so
# that it is all handled automatically.
################################################################
sub Assert : ATTR(CODE,BEGIN)
{
    my($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
    no strict "refs";
    my($subname, $tagref) = (*{$symbol}{NAME}, $data);
    $subname =~ /^assert_/
        || panic "$subname is not an assertion";

    my $his_export_ok = $package . "::EXPORT_OK";
    push @$his_export_ok, $subname;

    my $debugging = $Exporter::Verbose || $Assert_Debug;

    carp "Adding $subname to EXPORT_OK in $package at ",__FILE__," line ",__LINE__ if $debugging;

    if (defined($tagref) && !ref($tagref)) {
        $tagref = [ $tagref ];
    }
    my $his_export_tags = $package . "::EXPORT_TAGS";
    for my $tag (@$tagref, qw(all asserts)) {
        push @{ $his_export_tags->{$tag} }, $subname;
        carp "Adding $subname to EXPORT_TAG :$tag in $package at ",__FILE__," line ",__LINE__ if $debugging;
    }
}

lib/Assert/Conditional.pm  view on Meta::CPAN

# This one is a no-op!
sub assert_public_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from public method invoked as subroutine";
}

my %skip_caller = map { $_ => 1 } qw(
    Class::MOP::Method::Wrapped
    Moose::Meta::Method::Augmented
);

# And this one isn't *all* that hard... relatively speaking.
sub assert_private_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from private method invoked as subroutine";

    my $frame = 0;
    my @to    = caller $frame++;

    my @from = caller $frame++;
    while (@from && $skip_caller{ $from[CALLER_PACKAGE] }) {
        @from = caller $frame++;
    }

    my $msg = "private sub &$from[CALLER_SUBROUTINE] called from";
    @from || botch "ran out of stack while inspecting $msg";

    my @botches;

    $from[CALLER_PACKAGE]  eq $to[CALLER_PACKAGE]
        || push @botches, "alien package $from[CALLER_PACKAGE]" ;

    $from[CALLER_FILENAME]  eq $to[CALLER_FILENAME]
        || push @botches, "alien file $from[CALLER_FILENAME] line $from[CALLER_LINE]";

    @botches == 0
        || botch "$msg " . join(" at " => @botches);

}

# But this one? This one is RIDICULOUS. O Moose how we hates you
# foreverz for ruining perl's simple inheritance model and its export
# model and its import model and its package model till the end of time!
sub assert_protected_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from protected method invoked as subroutine";

    my $self;  # sic, no assignment
    my $frame = 0;

    my $next_frame = sub {
        package DB;
        our @args;
        my @frame = caller(1 + $frame++);
        $self = $args[0] // "undef";
        $self = "undef" if ref $self && !Scalar::Util::blessed($self);
        return @frame;
    };

    my @to   = $next_frame->();
    my @from = $next_frame->();
    while (@from && $skip_caller{ $from[CALLER_PACKAGE] }) {
        @from = $next_frame->();
    }

    my $msg = "protected sub &$from[CALLER_SUBROUTINE]";
    @from || botch "ran out of stack while inspecting $msg";

    (
                        $from[CALLER_PACKAGE]
                   ->isa( $to[CALLER_PACKAGE] )
        || $self->DOES( $from[CALLER_PACKAGE] )
    )   || botch join " " => ($msg,
               "called from unfriendly package"
                     => $from[CALLER_PACKAGE],
                at   => $from[CALLER_FILENAME],
                line => $from[CALLER_LINE]
           );

}

sub assert_known_package($)
    :Assert( qw[object ident] )
{
    &assert_nonempty;
    my($arg) = @_;
    my $stash = do { no strict "refs"; \%{ $arg . "::" } };
    no overloading;
    %$stash                     || botch "unknown package $arg";
}

sub assert_object($)
    :Assert( qw[object] )
{
    no overloading;
    &assert_anyref;
    my($arg) = @_;
    blessed($arg)               || botch "expected blessed referent not $arg";
}

sub assert_nonobject($)
    :Assert( qw[object] )
{
    no overloading;
    my($arg) = @_;
   !blessed($arg)               || botch "expected unblessed referent not $arg";
}

sub _get_invocant_type($) {
    my($invocant) = @_;
    my $type;
    if (blessed $invocant) {
        $type = "object";
    } else {