Improved replacement for Safe.pm

Safer.pm

package Safer;
$VERSION = '0.000001';
use strict;
use warnings;
use 5.010;
no overloading;

use Opcode qw,opset opset_to_hex invert_opset,;
use Scalar::Util qw,weaken blessed reftype,;
use Carp qw,croak,;
UNITCHECK {
	# Namespace cleaning... namespace::autoclean is overkill.
	my @go_away;
	BEGIN { @go_away = grep {/[^:]\z/ and defined &$_} keys %Safer:: };
	delete @Safer::{@go_away};
	delete @Safer::{grep /^_.*[^:]\z/, keys %Safer:: };
}

use constant { 
	SAFER_STRICT => 1,
	SAFER_NOWRAP_INCOMING => 2,
	SAFER_NOWRAP_OUTGOING => 4,
	SAFER_DIEONERR => 8,
};

BEGIN {
	no strict 'vars';
	no warnings 'once';
	@EXPORT_OK = grep /^SAFER_/, keys %Safer:: ;
	%EXPORT_TAGS = (all => \@EXPORT_OK, flags => \@EXPORT_OK);
	use Exporter qw,import,;
}

sub _lexless_evaller {
	eval pop
};

use constant _RECURSE => "Unexpected recursion";

sub new {
	my ($class, @opts) = @_;
	my $self = bless {}, $class;
	$self->permit_only( ":default" );
	my $root = $self->{root} = $self->next_root("Compartment");
	$root =~ /^(.*::)(.*::)$/ or die;
	$self->{branchname} = $1;
	$self->{leafname} = $2;
	{
		no strict 'refs';
		$self->{branch} = \%{ $self->{branchname} };
	}
	$self->erase;
	while( @opts ) {
		my ($meth, $val) = splice @opts, 0, 2;
		$self->$meth( ref($val) ? @$val : $val );
	}
	$self;
}

sub next_root {
	my ($self, $whatever) = @_;
	my $class = ref($self) || $self;
	state $counter = 0;
	$class . "::_${whatever}s::$whatever" . ++$counter  . "::";
}

sub erase {
	my ($self) = @_;
	$self->DESTROY;
	my $root = $self->{root};
	{
		no strict 'refs';
		*{$root . "main::"} = *$root;
		*{$root . "CORE::GLOBAL::"} = {};
		*{$root . "_"} = *_;
		*{$root . "INC"} = $_ for [], {};
		_set_hvname_to_main( \%$root );
	};
	$self->{leaf} = delete $self->{branch}{$self->{leafname}};
	$self->share_from( 'main', $self->default_share, 1 );
}

sub default_share {
	state $default_share;
	unless( $default_share ) {
		my $unload_after = !$main::{'Safe::'};
		eval q{
			require Safe;
			local *Safe::share_from = sub { $default_share ||= pop };
			local $Opcode::VERSION = 0;
			Safe->new;
		} or die $@;
		delete $main::{'Safe::'} if $unload_after;
		$default_share or die;
	}
	return [@$default_share];
};

sub reinit {
	my ($self) = @_;
	$self->erase;
	$self->share_redo;
}

sub mask {
	my ($self, $mask) = @_;
	if( @_ > 1 ) {
		$self->{mask} = $mask;
		$self;
	} else {
		$self->{mask};
	}
}

sub deny {
    my $self = shift;
    $self->{mask} |= opset(@_);
	$self;
}

sub deny_only {
    my $self = shift;
    $self->{mask} = opset(@_);
	$self;
}
 
sub permit {
    my $self = shift;
    $self->{mask} &= invert_opset opset(@_);
	$self;
}

sub permit_only {
    my $self = shift;
    $self->{mask} = invert_opset opset(@_);
	$self;
}

sub dump_mask {
    my $self = shift;
    print opset_to_hex($self->{mask}), "\n";
	$self;
}
 
sub share {
	my $self = shift;
    $self->share_from(scalar(caller), [@_] );
}

sub share_from {
	my ($self, $prefix, $vars, $no_record, $make_holes) = @_;
	croak("Package \"$prefix\" does not exist")
        unless keys %{"$prefix\::"};
	my $root = $self->{root};
	die _RECURSE if exists $self->{branch}{$self->{leafname}};
	local $self->{branch}{$self->{leafname}} = $self->{leaf};
	for (@$vars) {
		my ($type, $name) = m[^(\W?).*$]s or die;
		$type ||= '&';
		no strict 'refs';
		my $ref = 0 ? 'notreached'
			: ($type eq '&') ? \&{$prefix."::$name"}
			: ($type eq '$') ? \${$prefix."::$name"}
			: ($type eq '@') ? \@{$prefix."::$name"}
			: ($type eq '%') ? \%{$prefix."::$name"}
			: ($type eq '*') ?  *{$prefix."::$name"}
			: croak(qq(Can't share "$type${prefix}::$name" of unknown type));
		$ref = $self->wrap_code_hole($ref, SAFER_DIEONERR) if '&' eq $type and $make_holes;
		*{ $root . $name } = $ref for 1..2;
	}
	$self->share_record($prefix, $vars, $make_holes) unless $no_record;
	$self;
}

sub share_holes_from {
	my ($self, @args) = @_;
	$args[3] = 1;
	$self->share_from(@args);
}

sub share_record {
	my ($self, $prefix, $vars, $make_holes) = @_;
	@{$self->{shares}[!!$make_holes]{$prefix}{@$vars}} = ();
	$self;
}

sub share_redo {
	my ($self) = @_;
	my $all_shares = $self->{shares};
	for my $make_holes (0, 1) {
		my $shares = $all_shares->[$make_holes];
		for my $prefix (keys %$shares) {
			$self->share_from( $prefix, [ keys %{$shares->{$prefix}} ], 1, $make_holes );
		}
	}
	$self;
}

sub share_forget {
	my $self = shift;
	{
			@_ or delete($self->{shares}), last;
			my $p = shift;
			for my $make_hole (0, 1) {
				my $sh = $self->{shares}[$make_hole] or next;
				delete $sh->{$p}, next unless @_;
				delete $sh->{$p}{$_} for @_ > 1 ? @_ : ref($_[0]) ? @{$_[0]} : $_[0];
			}
	}
	$self;
}

sub varglob {
	my ($self, $var) = @_;
	die _RECURSE if exists $self->{branch}{$self->{leafname}};
	local $self->{branch}{$self->{leafname}} = $self->{leaf};
	no strict 'refs';
	*{$self->{root} . $var};
}

sub varglobs {
	my $self = shift;
	die _RECURSE if exists $self->{branch}{$self->{leafname}};
	local $self->{branch}{$self->{leafname}} = $self->{leaf};
	no strict 'refs';
	map *{$self->{root} . $_}, @_;
}

sub rcall {
	my ($self, $orig, $flags, @args) = @_;
	die _RECURSE if exists $self->{branch}{$self->{leafname}};
	my @call_in_cpt = ($self->{root}, $self->{mask}, sub {
			delete $self->{branch}{$self->{leafname}};
			$orig->(@args);
		}, ($self->{END_blocks} ||= []), wantarray );
	my @subret;
	my $err = do {
		local $@;
		local $self->{branch}{$self->{leafname}} = $self->{leaf};
		@subret = _call_in_cpt(@call_in_cpt);
		$self->wrap_danger_within( $@ );
		$@;
	};
	die $err if $flags & SAFER_DIEONERR and !defined $subret[0] and $err;
	# If code within the safe returns any blessed objects, each is replaced
	# with a blessed proxy object, which uses AUTOLOAD to intercept any and all
	# method calls, and perform them inside of the compartment.
	# Likewise, any coderefs are replaced by proxy coderefs.
	# If any tied objects are returned, they are untied, proxified, and retied.
	$self->wrap_danger_within( @subret ) unless $flags & SAFER_NOWRAP_OUTGOING;
	wantarray ? @subret : $subret[0];
}

sub wrap_code_ref {
	my ($self, $sub) = splice @_, 0, 2;
	my @args = @_;
	my $c = sub { $self->rcall( $sub, SAFER_DIEONERR, @args, @_ ) };
	weaken($self);
	return $c;
}

# Note that there is no corresponding unwrap_danger_within!
# If a compartment returns a coderef, and you want to pass that
# coderef back into the comparment, and call it there, it will still
# be a closure of the form sub { $safe->rcall($orig, $flags, @_) }...
# You probably should have passed the SAFER_NOWRAP_OUTGOING flag
# to rdo/reval/rcall.

# You don't have to tell me how horrible I am, for my use of global variables,
# but it does make _examine_and_mutate vastly more readable.

use vars qw,%_wrap_seen $_wrap_cpt,;
sub wrap_danger_within {
	local ($_wrap_cpt, %_wrap_seen) = (shift);
	_examine_and_mutate(@_);
}

sub reval {
	my ($self, $expr, $flags) = splice @_, 0, 3;
	$flags //= 0;
	$self->rcall( _evaller($self, $flags), $flags, $expr, @_ );
}

sub rdo {
	shift->rcall( sub { do $_[0] }, 0, @_ );
}

use constant object_wrapping_factory => do {
	package Safer::WrapObj;
	use vars qw,$AUTOLOAD,;
	sub new {
		my ($class, $safe, $obj, $weaken) = splice @_, 0, 4;
		my %self = (safe => $safe, obj => $obj, args0 => [@_]);
		if( $weaken ) {
			if( ref $weaken ) {
				weaken($self{$_}) for @$weaken;
			} elsif( $weaken eq 1 ) {
				weaken($self{$_}) for qw,safe obj,;
			} else {
				weaken($self{$weaken});
			}
		}
		bless \%self, $class;
	}
	# Destruction of a Safer::WrapObj only implies
	# that the wrapper went out of scope; the internal
	# object could very easily still exist.
	sub DESTROY { }
	sub AUTOLOAD {
		my $self = shift;
		(my $meth = $AUTOLOAD) =~ s/^.*:://;
		my @args = (@{$self->{args0}}, @_);
		$self->{safe}->rcall( sub { $self->{obj}->$meth( @args ) }, Safer::SAFER_DIEONERR );
	}
	;__PACKAGE__
};

sub wrap_obj {
	my $self = shift;
	$self->object_wrapping_factory->new( $self, @_ );
}

sub wrap_code_hole {
	my ($safe, $coderef, $flags) = splice @_, 0, 3;
	my @args0 = @_;
	my $ends = _endav();
	my $main = \%main:: ;
	$flags //= 0;
	_attach_current_opmask( $main );
	my $h = sub {
		my @args1 = @_;
		my $callme = sub {
			$safe->wrap_danger_within(@args1) unless $flags & SAFER_NOWRAP_INCOMING;
			delete local $safe->{branch}{$safe->{leafname}};
			$coderef->(@args0, @args1)
		};
		local $@;
		my @subret = _call_in_cpt( $main, undef, $callme, $ends, wantarray );
		die $@ if !$subret[0] and $@;
		wantarray ? @subret : $subret[0];
	};
	weaken($safe);
	weaken($main);
	return $h;
}

sub wrap_class_hole {
	my ($self, $real_class, $flags, $cpt_class) = @_;
	$flags //= SAFER_DIEONERR;
	$cpt_class //= $real_class;
	my $autoload = $self->varglob($cpt_class."::AUTOLOAD");
	my ($ok, $with_package);
	*$autoload = $self->wrap_code_hole(sub {
		(my $method = $$autoload) =~ s/.*:://;
		if( $ok = $real_class->can($method) ) {
			# The extra layer of indirection is necessary so that
			# caller() from within the called method will be correctish.
			local $self->{branch}{$self->{leafname}} = $self->{leaf};
			$with_package //= eval(
				"package $self->{root}$cpt_class; sub {&\$ok}" );
			return &$with_package;
		}
		croak("Can't locate object method \"$method\" via package \"$real_class\"");
	}, $flags);
	weaken($self);
	$self;
}

BEGIN {
	package # split across lines to hide from CPAN indexer
		Safer::::NoopUNTIE;
	use constant singleton => bless [];
	sub AUTOLOAD {singleton}
	sub UNTIE {}
	package # , which works because PAUSE is stupid.
		Safer::ReTIE;
	sub AUTOLOAD {pop};
}

sub _examine_and_mutate {
	for my $ref ( @_ ) {
		_examine_and_mutate( \$ref )
			if blessed(\$ref) or 'GLOB' eq ref \$ref;
		if( my $eviltie = tied $ref ) {
			tie $ref, Safer::::NoopUNTIE::;
			untie $ref;
			_examine_and_mutate( $eviltie, $ref );
			tie $ref, Safer::ReTIE::, $eviltie;
			next;
		}
		my $type = reftype $ref or next;
		if( exists $_wrap_seen{$ref} ) {
			$ref = $_wrap_seen{$ref} if defined $_wrap_seen{$ref};
			#weaken($ref);
			next;
		}
		undef $_wrap_seen{$ref};
		if( blessed( $ref ) ) {
			$_wrap_seen{$ref} = $_wrap_cpt->wrap_obj( $ref );
			$ref = $_wrap_seen{$ref};
			next;
		}
		if( 'SCALAR' eq $type or 'REF' eq $type ) {
			if( my $tied = tied $$ref ) {
				tie $$ref, Safer::::NoopUNTIE::;
				untie $$ref;
				_examine_and_mutate( $tied, $ref );
				tie $$ref, Safer::ReTIE::, $tied;
				next;
			}
			_examine_and_mutate( $$ref );
		} elsif( 'ARRAY' eq $type ) {
			if( my $tied = tied @$ref ) {
				tie @$ref, Safer::::NoopUNTIE::;
				untie @$ref;
				_examine_and_mutate( $tied, $ref );
				tie @$ref, Safer::ReTIE::, $tied;
				next;
			}
			_examine_and_mutate( @$ref );
		} elsif( 'HASH' eq $type ) {
			if( my $tied = tied %$ref ) {
				tie %$ref, Safer::::NoopUNTIE::;
				untie %$ref;
				_examine_and_mutate( $tied, $ref );
				tie %$ref, Safer::ReTIE::, $tied;
				next;
			}
			_examine_and_mutate( values @$ref );
		} elsif( 'CODE' eq $type ) {
			$_wrap_seen{$ref} = $_wrap_cpt->wrap_code_ref( $ref );
			$ref = $_wrap_seen{$ref};
		} elsif( 'GLOB' eq $type ) {
			if( my $tied = tied *$ref ) {
				tie *$ref, Safer::::NoopUNTIE::;
				untie *$ref;
				_examine_and_mutate( $tied, $ref );
				tie *$ref, Safer::ReTIE::, $tied;
				next;
			}
			my @names = qw,SCALAR CODE HASH ARRAY,;
			my @refs = grep defined, map *{$ref}{$_}, @names;
			_examine_and_mutate( @refs );
			*$ref = $_ for @refs;
		} else {
			# *GLOB{IO}, qr//, ??????
		}
	}
}

sub _evaller {
	my ($self, $flags) = @_;
	my $strict = !!($flags & SAFER_STRICT);
	# Note that the use/no strict is eval-ed in the normal namespace,
	# not within the comparment.
	return $self->{evaller}[ $strict ] ||= do {
		my $e = 'BEGIN { $^H = 0 };';
		$e .= ($strict ? "use strict;" : "no strict;");
		$e .= "package $self->{root};";
		$e .= "sub { eval shift }";
		die _RECURSE if exists $self->{branch}{$self->{leafname}};
		local $self->{branch}{$self->{leafname}} = $self->{leaf};
		_lexless_evaller($e) or die "Could not create evaller: $@";
	};
}

sub DESTROY {
	my ($self) = @_;
	my $leaf = delete $self->{leaf} or return;
	local $self->{branch}{$self->{leafname}} = $leaf;
	my $ends = delete $self->{END_blocks};
	_call_in_cpt($self->{root}, $self->{mask}, sub {
		delete $self->{branch}{$self->{leafname}};
		eval { pop(@$ends)->() } while @$ends;
		delete $leaf->{'main::'};
		undef(*$_), undef($_) for values %$leaf;
		%$leaf = ();
		undef *$leaf;
		undef $leaf;
		return;
	}, $ends, undef );
}

use Inline (C => <<'__C__');
void _set_hvname_to_main(SV *mainsv) {
	HV *mainhv;
	char *hvname;
	ENTER;
	if( !SvROK(mainsv) || SvTYPE(SvRV(mainsv)) != SVt_PVHV )
		croak("Usage: Safer::_set_hvname_to_main(HASHREF)");
	mainhv = (HV*)SvRV(mainsv);
	hvname = HvNAME(mainhv);
	if (!hvname || strNE(hvname,"main")) {
		hv_name_set(mainhv, "main", 4, 0);
	}
	LEAVE;
	return;
}

SV* _endav() {
	return sv_2mortal( newRV_inc( (SV*)PL_endav ) );
}

STATIC MGVTBL my_vtable = { 0, 0, 0, 0, 0, 0, 0, 0 };

void _attach_current_opmask(SV *mainsv) {
	ENTER;
	if( mg_findext( mainsv, PERL_MAGIC_ext, &my_vtable ) )
		return;
	sv_magicext( mainsv, NULL, PERL_MAGIC_ext, &my_vtable, PL_op_mask, 0 );
	LEAVE;
	return;
}

void _call_in_cpt(SV *mainsv, SV *opmasksv, SV *codesv, SV *endsv, SV *want) {
	static const char usage[] = "Usage: Safer::_call_in_cpt( hashref, opmask, coderef, arrayref, wantarray )";
	HV * mainhv;
	AV * endav;
	MAGIC *mg = NULL;
	int flags;
	
	ENTER;
	if( !SvROK(mainsv) || SvTYPE(SvRV(mainsv)) != SVt_PVHV ) croak(usage);
	if( !SvROK(codesv) || SvTYPE(SvRV(codesv)) != SVt_PVCV ) croak(usage);
	if( !SvROK(endsv) || SvTYPE(SvRV(endsv)) != SVt_PVAV ) croak(usage);
	if( !SvOK( opmasksv ) ) {
		mg = mg_findext( mainsv, PERL_MAGIC_ext, &my_vtable );
		if( !mg  ) croak("First argument lacks suitable magic");
	}
	
	mainhv = (HV*)SvRV(mainsv);
	if( strNE(HvNAME(mainhv), "main") )
		croak("Hash ref argument must be named 'main'");
	endav = (AV*)SvRV(endsv);
	
	SAVEVPTR(PL_op_mask);
	save_hptr(&PL_defstash);
	save_hptr(&PL_curstash);
	save_aptr(&PL_endav);
	SAVEVPTR(PL_incgv);
	save_hptr(&PL_globalstash);
	
	if( mg ) {
		
		PL_op_mask = mg->mg_ptr;
		
	} else {
		STRLEN len;
		int opcode, maxopcodes = PL_maxo;
		char * new_op_mask = NULL;
		char * packed_mask = SvPV(opmasksv, len);

		if( PL_op_mask ) {
			SV * tmp = sv_2mortal(newSVpvn(PL_op_mask, maxopcodes));
			new_op_mask = SvPV_nolen( tmp );
		} else {
			new_op_mask = sv_grow( sv_newmortal(), maxopcodes );
			memset( new_op_mask, 0, maxopcodes );
		}
		for( opcode = 0; opcode < maxopcodes; ++opcode ) {
			int i = opcode >> 3;
			int j = opcode & 7;
			if( i >= len ) break;
			new_op_mask[opcode] |= (packed_mask[i] >> j)&1;
		}
		
		PL_op_mask = new_op_mask;
	}
	
	PL_defstash = mainhv;
	PL_curstash = mainhv;
	PL_endav = endav;
	PL_incgv = gv_fetchpv("INC", GV_ADDWARN, SVt_PVHV);
	PL_globalstash = get_hv("CORE::GLOBAL::", GV_ADDWARN);
	
	/*PUSHMARK(SP);*/
	if( !SvOK( want ) )
		flags = G_VOID;
	else if( SvTRUE( want ) )
		flags = G_ARRAY;
	else
		flags = G_SCALAR;
	call_sv(codesv, flags|G_EVAL|G_KEEPERR);
	/* PUTBACK */
	LEAVE;
	return;
}
__C__

1;

__END__