File Coverage

blib/lib/Lexical/Failure.pm

Criterion	Covered	Total	%
statement	124	128	96.8
branch	43	64	67.1
condition	6	15	40.0
subroutine	20	20	100.0
pod	2	2	100.0
total	195	229	85.1

package Lexical::Failure;

use 5.014; use warnings;
no if $] >= 5.018, 'warnings', "experimental";
use Scope::Upper qw< want_at unwind uplevel CALLER UP SUB >;
use Carp qw< carp croak confess cluck >;
use Keyword::Simple;
use Attribute::Handlers;

use Lexical::Failure::Objects;

our $VERSION = '0.001000';

# Be invisible to Carp...
our @CARP_NOT = __PACKAGE__;

# Lexical hints are always at index 10 of caller()...
my $HINTS = 10;

# How to fail...
my %STD_FAILURE_HANDLERS = (
    'die'     => sub { _uplevel_die(@_);                      },
    'croak'   => sub { package Carp; uplevel { croak(@_)   } @_, CALLER($Lexical::Failure::uplevel); },
    'confess' => sub { package Carp; uplevel { confess(@_) } @_, CALLER($Lexical::Failure::uplevel); },
    'null'    => sub { return;                                },
    'undef'   => sub { return undef;                          },

    'failobj' => sub {
        uplevel { croak(@_)   } @_, CALLER($Lexical::Failure::uplevel) if !defined wantarray;
        return Lexical::Failure::Objects->new(
                    msg => (@_==1 ? $_[0] : "@_"),
                    context => [caller $Lexical::Failure::uplevel],
               );
    },
);

# Track handlers for lexical installations of fail()
my @ACTIVE_FAILURE_HANDLER_FOR_SCOPE;
my @VALID_FAILURE_HANDLERS_FOR_SCOPE;

# # 'croak' is the universal default failure handler...
my $DEF_NAMED_HANDLER = 'croak';
my $DEFAULT_SCOPE_ID = 0;
$ACTIVE_FAILURE_HANDLER_FOR_SCOPE[$DEFAULT_SCOPE_ID] = $STD_FAILURE_HANDLERS{$DEF_NAMED_HANDLER};

# Load the module...
sub import {
    my ($fail, $ON_FAILURE, $default, $handlers) = _process_import_args(@_);

    # Export API...
    Keyword::Simple::define $ON_FAILURE, _replace_keyword_with('Lexical::Failure::ON_FAILURE');
    Keyword::Simple::define $fail,       _replace_keyword_with('Lexical::Failure::fail');

    # Install specified failure handlers for the caller's scope...
    my $handlers_scope_ID = scalar @VALID_FAILURE_HANDLERS_FOR_SCOPE;
    $^H{'Lexical::Failure::handlers_scope_ID'} = $handlers_scope_ID;
    push @VALID_FAILURE_HANDLERS_FOR_SCOPE, { %STD_FAILURE_HANDLERS, %{$handlers} };

    # Install default failure handler for the caller's scope...
    if (ref($default) ne 'CODE') {
        croak "Unknown default failure handler: '$default'"
            if !exists $VALID_FAILURE_HANDLERS_FOR_SCOPE[-1]{$default};
        $default = $VALID_FAILURE_HANDLERS_FOR_SCOPE[-1]{$default};
    }
    my $default_scope_ID = scalar @ACTIVE_FAILURE_HANDLER_FOR_SCOPE;
    $^H{'Lexical::Failure::default_scope_ID'} = $default_scope_ID;
    push @ACTIVE_FAILURE_HANDLER_FOR_SCOPE, $default;

    return;
}

sub _process_import_args {
    my $package = shift;

    # What we're looking for (and their values if we don't find them)...
    my $fail       = 'fail';
    my $ON_FAILURE = 'ON_FAILURE';
    my $default    = 'croak';
    my $handlers   = {};

    # Trawl through the argument list...
    while (defined( my $next_arg = shift @_)) {
        if ($next_arg eq 'fail') {
            $fail = shift(@_)
                or croak "Missing rename for 'fail' in use $package";
            croak "Value for 'fail' option must be a string"
                if ref $fail;
        }
        elsif ($next_arg eq 'ON_FAILURE') {
            $ON_FAILURE = shift(@_)
                or croak "Missing rename for 'fail_width' in use $package";
            croak "Value for 'ON_FAILURE' option must be a string"
                if ref $fail;
        }
        elsif ($next_arg eq 'default') {
            $default = shift(@_)
                or croak "Missing specification for 'default' in use $package";
            croak "Value for 'default' option must be a string or subroutine reference"
                if ref $fail && ref $fail ne 'CODE';
        }
        elsif ($next_arg eq 'handlers') {
            $handlers = shift(@_)
                or croak "Missing specification for 'handlers' in use $package";
            croak "Value for 'handlers' option must be a hash reference"
                if !ref $handlers || ref $handlers ne 'HASH';
            croak "Handlers in 'handlers' hash must all be code references"
                if grep { ref($_) ne 'CODE' } values %{$handlers};
        }
        else {
            croak "Unexpected argument ($next_arg) in use $package"
        }
    }

    return ($fail, $ON_FAILURE, $default, $handlers);
}

sub _replace_keyword_with {
    my $replacement = shift;

    return sub {
        my ($src_ref) = @_;
        substr(${$src_ref}, 0, 0) = $replacement;
    }
}

sub ON_FAILURE {
    my $handler = shift;

    # No arg or undef arg --> no-op...
    return if !defined $handler;

    # Can't be called at runtime...
    if (${^GLOBAL_PHASE} ne 'START') {
        croak "Can't call ON_FAILURE after compilation"
    }

    # Can't be called outside a subroutine...
    if ((caller 1)[3] eq '(eval)') {
        croak "Can't call ON_FAILURE outside a subroutine"
    }

    # Can only be called with certain types of arguments...
    my $handler_type = ref $handler;
    croak "Invalid handler type ($handler_type ref) in call to ON_FAILURE"
        if $handler_type !~ m{\A (?: CODE | SCALAR | ARRAY | HASH | (?#STRING) ) \z}xms;

    # Which package is setting this handler???
    my $owner = caller;

    # Locate valid failure handlers...
    my $handlers_scope_ID = (caller 0)[$HINTS]{'Lexical::Failure::handlers_scope_ID'};
    my $valid_handlers_ref = $VALID_FAILURE_HANDLERS_FOR_SCOPE[$handlers_scope_ID];

    # Translate failure handlers (if necessary)...
    for my $type (ref $handler) {
        # Find handler for symbolic failure modes ('die', 'confess', etc.)...
        if ($type eq q{}) {
            croak "Unknown failure handler: '$handler'"
                if !exists $valid_handlers_ref->{$handler};
            $handler = $valid_handlers_ref->{$handler};
            last;
        }

        my $target_var = $handler;
        # _check_scoping_of($target_var); # Experimentally removed (may not be necessary)

        # Scalars are simply assigned to...
        if ($type eq 'SCALAR') {
            $handler = sub { ${$target_var} = [@_]; return; };
            last;
        }

        # Arrays are simply pushed onto...
        if ($type eq 'ARRAY') {
            $handler = sub { push @{$target_var}, [@_]; return; };
            last;
        }

        # Hashes are simply added to...
        if ($type eq 'HASH') {
            $handler = sub {
                my $caller_sub = (caller 2)[3];
                $target_var->{$caller_sub} = [@_];
                return;
            };
            last;
        }
    }

    # Install failure handler for the scope...
    my $scope_ID = scalar @ACTIVE_FAILURE_HANDLER_FOR_SCOPE;
    $^H{"Lexical::Failure::scope_ID::$owner"} = $scope_ID;
    push @ACTIVE_FAILURE_HANDLER_FOR_SCOPE, $handler;

    return;
}

# Fail by calling the appropriate handler...
sub fail {
    my (@msg) = @_;

    # Find the requested lexical handler...
    my $caller       = caller;
    my ($fail_handler, $uplevel) = _find_callers_handler($caller);

    # Determine original context of sub that's failing...
    my $context = want_at(CALLER($uplevel-1));

    # Ignore this code when croaking/carping from a handler
    package
    Carp;
    use Scope::Upper qw< unwind CALLER UP SUB>;

    # Simulate a return...
    unwind +( do {
                local $Lexical::Failure::uplevel = $uplevel;
                  !defined $context ?    do{ $fail_handler->(@msg); undef; }
                :        ! $context ? scalar $fail_handler->(@msg)
                :                            $fail_handler->(@msg)
              }
            ) => CALLER($uplevel-1);
}


# Locate hints hash of first scope outside caller (if any)...
sub _find_callers_handler {
    my ($immediate_caller_package) = @_;

    # Scope ID for default handler...
    my $default_scope_ID
        = (caller 1)[$HINTS]{'Lexical::Failure::default_scope_ID'}
        // $DEFAULT_SCOPE_ID;

    # Search upwards for first namespace different from $caller...
    LEVEL:
    for my $uplevel (2..10000) {
        my @uplevel_caller = caller($uplevel);

        # Give up if no higher contexts...
        last LEVEL if !@uplevel_caller;

        # Return handler for first different namespace (or else default handler)...
        if ($uplevel_caller[0] ne $immediate_caller_package) {
            my $target_scope_ID
                = $uplevel_caller[10]{"Lexical::Failure::scope_ID::$immediate_caller_package"}
                // $default_scope_ID;
            return $ACTIVE_FAILURE_HANDLER_FOR_SCOPE[ $target_scope_ID ], $uplevel;
        }
    }

    # If no such uplevel context, return a "null" hints hash...
    return $ACTIVE_FAILURE_HANDLER_FOR_SCOPE[ $default_scope_ID ], 0;
}


# Simulate a die() called at 2 levels higher up the stack...
sub _uplevel_die {
    my $exception = @_ ? join(q{},@_)
                  : $@ ? qq{$@\t...propagated}
                  :      q{Died};

    die $exception if ref $exception;

    if (!ref $exception && substr($exception, -1) ne "\n") {
        my (undef, $file, $line) = caller(2);
        $exception .= " at $file line $line\n";
    }

    die $exception;
}

1; # Magic true value required at end of module

__END__