[interchange] Embed Safe 2.07 into Vend::Safe to avoid various problems with recent versions of Safe.
Stefan Hornburg
interchange-cvs at icdevgroup.org
Wed May 29 13:33:28 UTC 2013
commit 6264540e5d33313d412c3c1899d1452b3e7ac311
Author: Peter Motschmann <pnm3 at optonline.com>
Date: Wed May 29 15:31:39 2013 +0200
Embed Safe 2.07 into Vend::Safe to avoid various problems with recent versions of Safe.
lib/Vend/Safe.pm | 228 ++++++++++++++++++++++++++++++++++++++++++++++++++----
1 files changed, 213 insertions(+), 15 deletions(-)
---
diff --git a/lib/Vend/Safe.pm b/lib/Vend/Safe.pm
index c9ae0de..061d86a 100644
--- a/lib/Vend/Safe.pm
+++ b/lib/Vend/Safe.pm
@@ -18,37 +18,69 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301 USA.
-# wrapper around Safe to return pre-inited Safe compartments which are utf-8 friendly.
+# 2013 update by Peter Motschmann <pnm3 at optonline.com>:
+# Integrated old version of Safe (2.07) directly into Vend::Safe because
+# new versions of Safe do not play nice with Interchange. Now we can go to any
+# version of perl without fear of Safe upgrades wrecking the site.
+
package Vend::Safe;
+use 5.003_11;
use strict;
use warnings;
+our $VERSION = "2.07";
+
use Vend::CharSet;
-use Safe;
+use Carp;
-# The L<new> method creates and returns an initialized Safe
-# compartment. This is mainly provided so there is a single point of
-# modification for all needed Safe.pm initializations.
+use Opcode 1.01, qw(
+ opset opset_to_ops opmask_add
+ empty_opset full_opset invert_opset verify_opset
+ opdesc opcodes opmask define_optag opset_to_hex
+);
+
+my $default_root = 0;
+my $default_share = ['*_']; #, '*main::'];
sub new {
- my ($invocant, @args) = @_;
+ my($class, $root, $mask) = @_;
+ my $obj = {};
+ bless $obj, $class;
- my $safe = Safe->new(@args);
- $invocant->initialize_safe_compartment($safe);
+ if (defined($root)) {
+ croak "Can't use \"$root\" as root name"
+ if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+ $obj->{Root} = $root;
+ $obj->{Erase} = 0;
+ }
+ else {
+ $obj->{Root} = "Safe::Root".$default_root++;
+ $obj->{Erase} = 1;
+ }
- return $safe;
-}
+ # use permit/deny methods instead till interface issues resolved
+ # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+ croak "Mask parameter to new no longer supported" if defined $mask;
+ $obj->permit_only(':default');
-# Initialize and sanity check the provided safe compartment. Code
-# here should be safe (ha, ha) to be run multiple times on the same
-# compartment.
+ # We must share $_ and @_ with the compartment or else ops such
+ # as split, length and so on won't default to $_ properly, nor
+ # will passing argument to subroutines work (via @_). In fact,
+ # for reasons I don't completely understand, we need to share
+ # the whole glob *_ rather than $_ and @_ separately, otherwise
+ # @_ in non default packages within the compartment don't work.
+ $obj->share_from('main', $default_share);
+ Opcode::_safe_pkg_prep($obj->{Root});
+
+ $class->initialize_safe_compartment($obj);
+
+ return $obj;
+}
sub initialize_safe_compartment {
my ($class, $compartment) = @_;
-#::logDebug("Initializing Safe compartment");
-
# force load of the unicode libraries in global perl
qr{\x{0100}i};
@@ -71,4 +103,170 @@ sub initialize_safe_compartment {
$@ and ::logError("Failed compiling UTF-8 regular expressions in a Safe compartment with restricted opcode mask. This may affect code in perl or calc blocks in your pages if you are processing UTF-8 strings in them. Error: %s", $@);
}
+sub DESTROY {
+ my $obj = shift;
+ $obj->erase('DESTROY') if $obj->{Erase};
+}
+
+sub erase {
+ my ($obj, $action) = @_;
+ my $pkg = $obj->root();
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::";
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ my $stem_symtab = *{$stem}{HASH};
+
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
+ %$leaf_symtab = ();
+
+ if ($action and $action eq 'DESTROY') {
+ delete $stem_symtab->{$leaf};
+ }
+ else {
+ $obj->share_from('main', $default_share);
+ }
+ 1;
+}
+
+sub reinit {
+ my $obj= shift;
+ $obj->erase;
+ $obj->share_redo;
+}
+
+sub root {
+ my $obj = shift;
+ croak("Safe root method now read-only") if @_;
+ return $obj->{Root};
+}
+
+sub mask {
+ my $obj = shift;
+ return $obj->{Mask} unless @_;
+ $obj->deny_only(@_);
+}
+
+# v1 compatibility methods
+sub trap { shift->deny(@_) }
+sub untrap { shift->permit(@_) }
+
+sub deny {
+ my $obj = shift;
+ $obj->{Mask} |= opset(@_);
+}
+sub deny_only {
+ my $obj = shift;
+ $obj->{Mask} = opset(@_);
+}
+
+sub permit {
+ my $obj = shift;
+ # XXX needs testing
+ $obj->{Mask} &= invert_opset opset(@_);
+}
+sub permit_only {
+ my $obj = shift;
+ $obj->{Mask} = invert_opset opset(@_);
+}
+
+sub dump_mask {
+ my $obj = shift;
+ print opset_to_hex($obj->{Mask}),"\n";
+}
+
+sub share {
+ my($obj, @vars) = @_;
+ $obj->share_from(scalar(caller), \@vars);
+}
+
+sub share_from {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $no_record = shift || 0;
+ my $root = $obj->root();
+ croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+ no strict 'refs';
+ # Check that 'from' package actually exists
+ croak("Package \"$pkg\" does not exist")
+ unless keys %{"$pkg\::"};
+ my $arg;
+ foreach $arg (@$vars) {
+ # catch some $safe->share($var) errors:
+ croak("'$arg' not a valid symbol table name")
+ unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
+ or $arg =~ /^\$\W$/;
+ my ($var, $type);
+ $type = $1 if ($var = $arg) =~ s/^(\W)//;
+ # warn "share_from $pkg $type $var";
+ *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
+ : ($type eq '&') ? \&{$pkg."::$var"}
+ : ($type eq '$') ? \${$pkg."::$var"}
+ : ($type eq '@') ? \@{$pkg."::$var"}
+ : ($type eq '%') ? \%{$pkg."::$var"}
+ : ($type eq '*') ? *{$pkg."::$var"}
+ : croak(qq(Can't share "$type$var" of unknown type));
+ }
+ $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+}
+
+sub share_record {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ # Record shares using keys of $obj->{Shares}. See reinit.
+ @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+}
+
+sub share_redo {
+ my $obj = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ my($var, $pkg);
+ while(($var, $pkg) = each %$shares) {
+ # warn "share_redo $pkg\:: $var";
+ $obj->share_from($pkg, [ $var ], 1);
+ }
+}
+
+sub share_forget {
+ delete shift->{Shares};
+}
+
+sub varglob {
+ my ($obj, $var) = @_;
+ no strict 'refs';
+ return *{$obj->root()."::$var"};
+}
+
+sub reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ # Create anon sub ref in root of compartment.
+ # Uses a closure (on $expr) to pass in the code to be executed.
+ # (eval on one line to keep line numbers as expected by caller)
+ my $evalcode = sprintf('package %s; sub { eval $expr; }', $root);
+ my $evalsub;
+
+ if ($strict) { use strict; $evalsub = eval $evalcode; }
+ else { no strict; $evalsub = eval $evalcode; }
+
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = eval
+ sprintf('package %s; sub { do $file }', $root);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
1;
+__END__
More information about the interchange-cvs
mailing list