File Coverage

blib/lib/Eval/Quosure.pm

Criterion	Covered	Total	%
statement	60	64	93.7
branch	7	10	70.0
condition	4	4	100.0
subroutine	16	16	100.0
pod	4	5	80.0
total	91	99	91.9

package Eval::Quosure;

# ABSTRACT: Evaluate within a caller environment

use 5.010;
use strict;
use warnings;

our $VERSION = '0.001001'; # VERSION

use List::Util 1.28 qw(pairmap);
use PadWalker 2.3 qw(peek_my peek_our);
use Safe::Isa 1.000009;
use Sub::Quote 2.005 qw(quote_sub);
use Type::Params 1.004004;
use Types::Standard qw(Str Int HashRef Optional);

sub new {
    state $check = Type::Params::compile( Str, Optional [Int] );

    my $class = shift;
    my ( $expr, $level ) = $check->(@_);
    $level //= 0;

    my $captures = {
        pairmap { $a => $b }
        ( %{ peek_our( $level + 1 ) }, %{ peek_my( $level + 1 ) } )
    };

    my $self = bless {
        expr     => $expr,
        captures => $captures,
        caller   => [ caller($level) ],
    }, $class;
    return $self;
}


sub expr     { $_[0]->{expr} }
sub captures { $_[0]->{captures} }
sub caller   { $_[0]->{caller} }


sub eval {
    state $check = Type::Params::compile( Optional [HashRef] );

    my $self = shift;
    my ($additional_captures) = $check->(@_);
    $additional_captures //= {};

    my $captures =
      { %{ $self->captures }, pairmap { $a => \$b } %$additional_captures };
    my $caller = $self->caller;

    my $coderef = quote_sub(
        undef,
        $self->expr,
        $captures,
        {
            no_install => 1,              # do not install the function
            package    => $caller->[0],
            file       => $caller->[1],
            line       => $caller->[2],

            # Without below it would get error with Function::Parameters
            #  https://rt.cpan.org/Public/Bug/Display.html?id=122698
            hintshash => undef,
        }
    );

    my @rslt;
    if (wantarray) {
        @rslt = eval { $coderef->(); };
    }
    elsif ( defined wantarray ) {
        $rslt[0] = eval { $coderef->(); };
    }
    else {
        eval { $coderef->(); };
    }
    if ($@) {

        # Simplify error message as sometimes part of what's come from
        #  Sub::Quote may not be very meaningful to users.
        # See also https://metacpan.org/source/HAARG/Sub-Quote-2.006003/lib/Sub/Quote.pm#L307
        my $msg = $@;
        $msg =~ s/.*\d+:.*?[\n]+//ms;
        die $msg;
    }
    if (wantarray) {
        return @rslt;
    }
    elsif ( defined wantarray ) {
        return $rslt[0];
    }
    else {
        return;
    }
}

1;

__END__