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