Safe

 view release on metacpan or  search on metacpan

Safe.pm  view on Meta::CPAN

    if (defined &B::sub_generation) {
        *sub_generation = \&B::sub_generation;
    }
    else {
        # fake sub generation changing for perls < 5.8.9
        my $sg; *sub_generation = sub { ++$sg };
    }
}

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
);

*ops_to_opset = \&opset;   # Temporary alias for old Penguins

# Regular expressions and other unicode-aware code may need to call
# utf8->SWASHNEW (via perl's utf8.c).  That will fail unless we share the
# SWASHNEW method.
# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
# and sharing makes it look like the method exists.
# The simplest and most robust fix is to ensure the utf8 module is loaded when
# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
require utf8;

Safe.pm  view on Meta::CPAN

    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 {

Safe.pm  view on Meta::CPAN

Code evaluated in a compartment compiles subject to the
compartment's operator mask. Attempting to evaluate code in a
compartment which contains a masked operator will cause the
compilation to fail with an error. The code will not be executed.

The default operator mask for a newly created compartment is
the ':default' optag.

It is important that you read the L<Opcode> module documentation
for more information, especially for detailed definitions of opnames,
optags and opsets.

Since it is only at the compilation stage that the operator mask
applies, controlled access to potentially unsafe operations can
be achieved by having a handle to a wrapper subroutine (written
outside the compartment) placed into the compartment. For example,

    $cpt = new Safe;
    sub wrapper {
        # vet arguments and perform potentially unsafe operations
    }

t/safe1.t  view on Meta::CPAN

}

# Tests Todo:
#	'main' as root

package test;	# test from somewhere other than main

use vars qw($bar);

use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
	opmask_add full_opset empty_opset opcodes opmask define_optag);

use Safe 1.00;
use Test::More;

my $cpt;
# create and destroy some automatic Safe compartments first
$cpt = new Safe or die;
$cpt = new Safe or die;
$cpt = new Safe or die;

t/safe2.t  view on Meta::CPAN

        print "1..0\n";
        exit 0;
    }
}

# Tests Todo:
#	'main' as root

use vars qw($bar);

use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
	opmask_add full_opset empty_opset opcodes opmask define_optag);

use Safe 1.00;

use Test::More;
my $TB = Test::Builder->new();

# Set up a package namespace of things to be visible to the unsafe code
$Root::foo = "visible";
$bar = "invisible";

t/safe2.t  view on Meta::CPAN

push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."

is($Root::foo, 'ok 17');
is("@{$cpt->varglob('bar')}", 'ok 18');

use strict;

my $m1 = $cpt->mask;
$cpt->trap("negate");
my $m2 = $cpt->mask;
my @masked = opset_to_ops($m1);
is(opset("negate", @masked), $m2);

is(eval { $cpt->mask("a bad mask") }, undef);
isnt($@, '');

is($cpt->reval("2 + 2"), 4);

my $test = $TB->current_test() + 1;
my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'");
++$test;
my @t_array  = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)");

t/safeutf8.t  view on Meta::CPAN

    require Config; import Config;
    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
        print "1..0\n";
        exit 0;
    }
}

use Test::More tests => 7;

use Safe 1.00;
use Opcode qw(full_opset);

pass;

my $safe = Safe->new('PLPerl');
$safe->deny_only();

# Expression that triggers require utf8 and call to SWASHNEW.
# Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called"
# if SWASHNEW is not shared, else returns true if unicode logic is working.
my $trigger = q{ my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };