Skip to content

Commit

Permalink
Revert "Embed Safe 2.07 into Vend::Safe to avoid various problems wit…
Browse files Browse the repository at this point in the history 
…h 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 6264540.
  • Loading branch information
David Christensen committed Jul 18, 2014
1 parent 44f5e44 commit e807fc9
Showing 1 changed file with 15 additions and 213 deletions.
228 changes: 15 additions & 213 deletions lib/Vend/Safe.pm
View file
Expand Up @@ -18,69 +18,37 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301 USA.

# 2013 update by Peter Motschmann <pnm3@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.

# 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};

Expand All @@ -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__

0 comments on commit e807fc9

Please sign in to comment.