view release on metacpan or  search on metacpan

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

    $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{

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

{
    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->();
    }

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

        $sub = his_sub(++$i);
    }
    $sub =~ s/.*:://;
    return $sub;
}

sub his_args(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    do { package DB; () = caller($frames+2); };
    return @DB::args;
}

sub his_frame(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    return caller($frames+2);
}

BEGIN {

    # Stealing lovely "iota" magic from the
    # Go language construct of the same name.
    my      $iota;
    BEGIN { $iota = 0 }
    use constant {
        CALLER_PACKAGE     =>  $iota++,