[interchange] Revert "Embed Safe 2.07 into Vend::Safe to avoid various problems with recent versions of Safe."

commit e807fc9009616fdaa03970432be33e227a7b7dda
Author: David Christensen <[email protected]>
Date:   Fri Jul 18 12:45:23 2014 -0500

    Revert "Embed Safe 2.07 into Vend::Safe to avoid various problems with recent versions of Safe."
    
    This is broken in at least perl 5.20, possibly earlier; I also don't believe that this is a good
    approach to take, particularly as the Safe module relies on specific internal perl modules which we
    are also currently not including (nor could we effectively).
    
    I *would* be interested to look at the issues that this commit was intended to fix, to see if we can
    come up with a better general-purpose solution which works across multiple versions of perl and
    Safe.
    
    This reverts commit 6264540e5d33313d412c3c1899d1452b3e7ac311.

 lib/Vend/Safe.pm |  228 ++++--------------------------------------------------
 1 files changed, 15 insertions(+), 213 deletions(-)
---
diff --git a/lib/Vend/Safe.pm b/lib/Vend/Safe.pm
index 061d86a..c9ae0de 100644
--- a/lib/Vend/Safe.pm
+++ b/lib/Vend/Safe.pm
@@ -18,69 +18,37 @@
 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
 # MA  02110-1301  USA.
 
-# 2013 update by Peter Motschmann <[email protected]>:
-# 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.
-
+# wrapper around Safe to return pre-inited Safe compartments which are utf-8 friendly.
 package Vend::Safe;
-use 5.003_11;
 
 use strict;
 use warnings;
 
-our $VERSION = "2.07";
-
 use Vend::CharSet;
-use Carp;
+use Safe;
 
-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::'];
+# 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.
 
 sub new {
-    my($class, $root, $mask) = @_;
-    my $obj = {};
-    bless $obj, $class;
-
-    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;
-    }
+    my ($invocant, @args) = @_;
 
-    # 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');
+    my $safe = Safe->new(@args);
+    $invocant->initialize_safe_compartment($safe);
 
-    # 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;
+    return $safe;
 }
 
+# Initialize and sanity check the provided safe compartment.  Code
+# here should be safe (ha, ha) to be run multiple times on the same
+# compartment.
+
 sub initialize_safe_compartment {
     my ($class, $compartment) = @_;
 
+#::logDebug("Initializing Safe compartment");
+
     # force load of the unicode libraries in global perl
     qr{\x{0100}i};
 
@@ -103,170 +71,4 @@ 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__