1# See copyright, etc in below POD section. 2###################################################################### 3 4package Schedule::Load::Safe; 5require 5.004; 6 7use Safe; 8 9use strict; 10use vars qw($VERSION $Debug); 11use Carp; 12 13###################################################################### 14#### Configuration Section 15 16$VERSION = '3.064'; 17 18###################################################################### 19#### Creators 20 21sub new { 22 my $proto = shift; 23 my $class = ref($proto) || $proto; 24 my $self = { 25 _cache => {}, 26 cache_max_entries => 1000, # Maximum size of the cache (so we don't run out of memory) 27 @_,}; 28 bless $self, $class; 29 return $self; 30} 31 32###################################################################### 33#### Evaluation 34 35sub _cache_check { 36 my $self = shift; 37 if (keys (%{$self->{_cache}}) > $self->{cache_max_entries}) { 38 # For speed, rather than a single entry, delete random ~10% of entries. 39 foreach my $key (keys %{$self->{_cache}}) { 40 if (rand(10)<=1.0) { 41 delete $self->{_cache}{$key}; 42 } 43 } 44 } 45} 46 47sub eval_cb { 48 my $self = shift; 49 my $subref = shift; 50 my @subargs = @_; 51 # Call &$subref($subargs) in safe container 52 if (ref $subref) { 53 return $subref->(@subargs); 54 } else { 55 if (!exists $self->{_cache}{$subref}) { 56 my $compartment = new Safe; 57 $compartment->permit(qw(:base_core)); 58 $@ = ""; 59 my $code = $compartment->reval($subref); 60 if ($@ || !$code) { 61 print "eval_match: $@: $subargs[0]\n" if $Debug; 62 $self->{_cache}{$subref} = undef; 63 return undef; 64 65 } 66 $self->_cache_check(); 67 $self->{_cache}{$subref} = $code; 68 } 69 my $code = $self->{_cache}{$subref}; 70 return undef if !defined $code; 71 my $result = $code->(@subargs); 72 if ($Debug && $Debug>1) { # Try again in non-safe container 73 my $dcode = eval($subref); 74 my $dresult = $dcode->(@subargs); 75 die "%Error: Safe mismatch: '$result' ne '$dresult'\n" if $dresult ne $result; 76 } 77 return $result; 78 } 79} 80 81###################################################################### 82###################################################################### 831; 84__END__ 85 86=pod 87 88=head1 NAME 89 90Schedule::Load::Safe - Evaluate callback in Safe container with caching 91 92=head1 SYNOPSIS 93 94 See Schedule::Load::Schedule 95 96=head1 DESCRIPTION 97 98This package is for internal use of Schedule::Load. It allows a function 99to be defined inside a Safe container, then saved inside a cache for later 100use. This is significantly faster than creating a safe container for each 101evaluation. 102 103=head1 DISTRIBUTION 104 105The latest version is available from CPAN and from L<http://www.veripool.org/>. 106 107Copyright 1998-2011 by Wilson Snyder. This package is free software; you 108can redistribute it and/or modify it under the terms of either the GNU 109Lesser General Public License Version 3 or the Perl Artistic License Version 2.0. 110 111=head1 AUTHORS 112 113Wilson Snyder <wsnyder@wsnyder.org> 114 115=head1 SEE ALSO 116 117L<Schedule::Load> 118 119=cut 120