File Coverage

blib/lib/Schedule/Load/Safe.pm

Criterion	Covered	Total	%
statement	33	48	68.7
branch	8	18	44.4
condition	2	9	22.2
subroutine	6	7	85.7
pod	0	2	0.0
total	49	84	58.3

# See copyright, etc in below POD section.
######################################################################

package Schedule::Load::Safe;
require 5.004;

use Safe;

use strict;
use vars qw($VERSION $Debug);
use Carp;

######################################################################
#### Configuration Section

$VERSION = '3.064';

######################################################################
#### Creators

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {
	_cache => {},
	cache_max_entries => 1000,	# Maximum size of the cache (so we don't run out of memory)
	@_,};
    bless $self, $class;
    return $self;
}

######################################################################
#### Evaluation

sub _cache_check {
    my $self = shift;
    if (keys (%{$self->{_cache}}) > $self->{cache_max_entries}) {
	# For speed, rather than a single entry, delete random ~10% of entries.
	foreach my $key (keys %{$self->{_cache}}) {
	    if (rand(10)<=1.0) {
		delete $self->{_cache}{$key};
	    }
	}
    }
}

sub eval_cb {
    my $self = shift;
    my $subref = shift;
    my @subargs = @_;
    # Call &$subref($subargs) in safe container
    if (ref $subref) {
	return $subref->(@subargs);
    } else {
	if (!exists $self->{_cache}{$subref}) {
	    my $compartment = new Safe;
	    $compartment->permit(qw(:base_core));
	    $@ = "";
	    my $code = $compartment->reval($subref);
	    if ($@ || !$code) {
		print "eval_match: $@: $subargs[0]\n" if $Debug;
		$self->{_cache}{$subref} = undef;
		return undef;

	    }
	    $self->_cache_check();
	    $self->{_cache}{$subref} = $code;
	}
	my $code = $self->{_cache}{$subref};
	return undef if !defined $code;
	my $result = $code->(@subargs);
	if ($Debug && $Debug>1) {   # Try again in non-safe container
	    my $dcode = eval($subref);
	    my $dresult = $dcode->(@subargs);
	    die "%Error: Safe mismatch: '$result' ne '$dresult'\n" if $dresult ne $result;
	}
	return $result;
    }
}

######################################################################
######################################################################
1;
__END__