view release on metacpan or  search on metacpan

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

{
    my($msg) = @_;
    local @SIG{<__{DIE,WARN}__>} unless $Allow_Handlers;
    Carp::confess("Panicking on internal error: $msg");
}

sub FIXME()
    :Export( qw[lint] )
{
    panic "Unimplemented code reached; you forgot to code up a TODO section";
}

sub NOT_REACHED()
    :Export( qw[lint] )
{
    panic "Logically unreachable code somehow reached";
}

#################################################################

# Find the highest assert_ on the stack so that we don't misreport
# failures. For example this next one illustrated below should be
# reporting that assert_hash_keys_required botched because that's the
# one we called; it shouldn't say that it was assert_min_keys or
# assert_hashref_keys_required that botched, even thought the nearest
# assert that called botch was actually assert_min_keys.

## perl -Ilib -MAssert::Conditional=:all -e 'assert_hash_keys_required %ENV, "snap"'
## -e[92241]: botched assertion assert_hash_keys_required: Key 'snap' missing from hash, bailing out at -e line 1.
##
##    Beginning stack dump from failed assert_hash_keys_required at lib/Assert/Conditional/Utils.pm line 391.
## 	Assert::Conditional::Utils::botch("key 'snap' missing from hash") called at lib/Assert/Conditional.pm line 1169
## 	Assert::Conditional::assert_min_keys(REF(0x7fe6196ec3f0), "snap") called at lib/Assert/Conditional.pm line 1135
## 	Assert::Conditional::assert_hashref_keys_required called at lib/Assert/Conditional.pm line 1104
## 	Assert::Conditional::assert_hash_keys_required(HASH(0x7fe619028f70), "snap") called at -e line 1

# But if we can't find as assert_\w+ on the stack, just use the name of the
# the thing that called the thing that called us, so presumably whatever
# called botch.
sub his_assert()
    :Export( qw[frame] )
{
    my $assert_rx = qr/::assert_\w+\z/x;
    my $i;
    my $sub = q();
    for ($i = 1; $sub !~ $assert_rx; $i++)  {
        $sub = his_sub($i) // last;
    }
    $sub //= his_sub(2); # in case we couldn't find an assert_\w+ sub
    while ((his_sub($i+1) // "") =~ $assert_rx) {
        $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++,
        CALLER_FILENAME    =>  $iota++,
        CALLER_LINE        =>  $iota++,
        CALLER_SUBROUTINE  =>  $iota++,
        CALLER_HASARGS     =>  $iota++,
        CALLER_WANTARRAY   =>  $iota++,
        CALLER_EVALTEXT    =>  $iota++,
        CALLER_IS_REQUIRE  =>  $iota++,
        CALLER_HINTS       =>  $iota++,
        CALLER_BITMASK     =>  $iota++,
        CALLER_HINTHASH    =>  $iota++,
    };

    my @caller_consts = qw(
        CALLER_PACKAGE
        CALLER_FILENAME
        CALLER_LINE
        CALLER_SUBROUTINE
        CALLER_HASARGS
        CALLER_WANTARRAY
        CALLER_EVALTEXT
        CALLER_IS_REQUIRE
        CALLER_HINTS
        CALLER_BITMASK
        CALLER_HINTHASH
    );

    push @{ $EXPORT_TAGS{CALLER} }, @caller_consts;

    push @{ $EXPORT_TAGS{frame}  },
         @{ $EXPORT_TAGS{CALLER} };

}

sub his_package(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_PACKAGE]
}

sub his_filename(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_FILENAME]
}

sub his_line(;$)
    :Export( qw[frame] )
{