1 files changed, 670 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/ext/Safe/Safe.pm b/gnu/usr.bin/perl/ext/Safe/Safe.pm
new file mode 100644
index 00000000000..0fafcbe7411
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Safe/Safe.pm
@@ -0,0 +1,670 @@
+package Safe;
+
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+require Exporter;
+require DynaLoader;
+use Carp;
+$VERSION = "1.00";
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname opdesc
+		MAXO emptymask fullmask);
+
+=head1 NAME
+
+Safe - Safe extension module for Perl
+
+=head1 DESCRIPTION
+
+The Safe extension module allows the creation of compartments
+in which perl code can be evaluated. Each compartment has
+
+=over 8
+
+=item a new namespace
+
+The "root" of the namespace (i.e. "main::") is changed to a
+different package and code evaluated in the compartment cannot
+refer to variables outside this namespace, even with run-time
+glob lookups and other tricks. Code which is compiled outside
+the compartment can choose to place variables into (or share
+variables with) the compartment's namespace and only that
+data will be visible to code evaluated in the compartment.
+
+By default, the only variables shared with compartments are the
+"underscore" variables $_ and @_ (and, technically, the much less
+frequently used %_, the _ filehandle and so on). This is because
+otherwise perl operators which default to $_ will not work and neither
+will the assignment of arguments to @_ on subroutine entry.
+
+=item an operator mask
+
+Each compartment has an associated "operator mask". Recall that
+perl code is compiled into an internal format before execution.
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+Code evaulated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaulate code in a
+compartment which contains a masked operator will cause the
+compilation to fail with an error. The code will not be executed.
+
+By default, the operator mask for a newly created compartment masks
+out all operations which give "access to the system" in some sense.
+This includes masking off operators such as I<system>, I<open>,
+I<chown>, and I<shmget> but does not mask off operators such as
+I<print>, I<sysread> and I<E<lt>HANDLE<gt>>. Those file operators
+are allowed since for the code in the compartment to have access
+to a filehandle, the code outside the compartment must have explicitly
+placed the filehandle variable inside the compartment.
+
+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
+    }
+    $cpt->share('&wrapper');
+
+=back
+
+=head2 Operator masks
+
+An operator mask exists at user-level as a string of bytes of length
+MAXO, each of which is either 0x00 or 0x01. Here, MAXO is the number
+of operators in the current version of perl. The subroutine MAXO()
+(available for export by package Safe) returns the number of operators
+in the current version of perl. Note that, unlike the beta versions of
+the Safe extension, this is a reliable count of the number of
+operators in the currently running perl executable. The presence of a
+0x01 byte at offset B<n> of the string indicates that operator number
+B<n> should be masked (i.e. disallowed).  The Safe extension makes
+available routines for converting from operator names to operator
+numbers (and I<vice versa>) and for converting from a list of operator
+names to the corresponding mask (and I<vice versa>).
+
+=head2 Methods in class Safe
+
+To create a new compartment, use
+
+    $cpt = new Safe;
+
+Optional arguments are (NAMESPACE, MASK), where
+
+=over 8
+
+=item NAMESPACE
+
+is the root namespace to use for the compartment (defaults to
+"Safe::Root000000000", auto-incremented for each new compartment); and
+
+=item MASK
+
+is the operator mask to use (defaults to a fairly restrictive set).
+
+=back
+
+The following methods can then be used on the compartment
+object returned by the above constructor. The object argument
+is implicit in each case.
+
+=over 8
+
+=item root (NAMESPACE)
+
+This is a get-or-set method for the compartment's namespace. With the
+NAMESPACE argument present, it sets the root namespace for the
+compartment. With no NAMESPACE argument present, it returns the
+current root namespace of the compartment.
+
+=item mask (MASK)
+
+This is a get-or-set method for the compartment's operator mask.
+With the MASK argument present, it sets the operator mask for the
+compartment. With no MASK argument present, it returns the
+current operator mask of the compartment.
+
+=item trap (OP, ...)
+
+This sets bits in the compartment's operator mask corresponding
+to each operator named in the list of arguments. Each OP can be
+either the name of an operation or its number. See opcode.h or
+opcode.pl in the main perl distribution for a canonical list of
+operator names.
+
+=item untrap (OP, ...)
+
+This resets bits in the compartment's operator mask corresponding
+to each operator named in the list of arguments. Each OP can be
+either the name of an operation or its number. See opcode.h or
+opcode.pl in the main perl distribution for a canonical list of
+operator names.
+
+=item share (VARNAME, ...)
+
+This shares the variable(s) in the argument list with the compartment.
+Each VARNAME must be the B<name> of a variable with a leading type
+identifier included. Examples of legal variable names are '$foo' for
+a scalar, '@foo' for an array, '%foo' for a hash, '&foo' for a
+subroutine and '*foo' for a glob (i.e. all symbol table entries
+associated with "foo", including scalar, array, hash, sub and filehandle).
+
+=item varglob (VARNAME)
+
+This returns a glob for the symbol table entry of VARNAME in the package
+of the compartment. VARNAME must be the B<name> of a variable without
+any leading type marker. For example,
+
+    $cpt = new Safe 'Root';
+    $Root::foo = "Hello world";
+    # Equivalent version which doesn't need to know $cpt's package name:
+    ${$cpt->varglob('foo')} = "Hello world";
+
+
+=item reval (STRING)
+
+This evaluates STRING as perl code inside the compartment. The code
+can only see the compartment's namespace (as returned by the B<root>
+method). Any attempt by code in STRING to use an operator which is
+in the compartment's mask will cause an error (at run-time of the
+main program but at compile-time for the code in STRING). The error
+is of the form "%s trapped by operation mask operation...". If an
+operation is trapped in this way, then the code in STRING will not
+be executed. If such a trapped operation occurs or any other
+compile-time or return error, then $@ is set to the error message,
+just as with an eval(). If there is no error, then the method returns
+the value of the last expression evaluated, or a return statement may
+be used, just as with subroutines and B<eval()>. Note that this
+behaviour differs from the beta distribution of the Safe extension
+where earlier versions of perl made it hard to mimic the return
+behaviour of the eval() command.
+
+=item rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=back
+
+=head2 Subroutines in package Safe
+
+The Safe package contains subroutines for manipulating operator
+names and operator masks. All are available for export by the package.
+The canonical list of operator names is the contents of the array
+op_name defined and initialised in file F<opcode.h> of the Perl
+source distribution.
+
+=over 8
+
+=item ops_to_mask (OP, ...)
+
+This takes a list of operator names and returns an operator mask
+with precisely those operators masked.
+
+=item mask_to_ops (MASK)
+
+This takes an operator mask and returns a list of operator names
+corresponding to those operators which are masked in MASK.
+
+=item opcode (OP, ...)
+
+This takes a list of operator names and returns the corresponding
+list of opcodes (which can then be used as byte offsets into a mask).
+
+=item opname (OP, ...)
+
+This takes a list of opcodes and returns the corresponding list of
+operator names.
+
+=item fullmask
+
+This just returns a mask which has all operators masked.
+It returns the string "\1" x MAXO().
+
+=item emptymask
+
+This just returns a mask which has all operators unmasked.
+It returns the string "\0" x MAXO(). This is useful if you
+want a compartment to make use of the namespace protection
+features but do not want the default restrictive mask.
+
+=item MAXO
+
+This returns the number of operators (and hence the length of an
+operator mask). Note that, unlike the beta distributions of the
+Safe extension, this is derived from a genuine integer variable
+in the perl executable and not from a preprocessor constant.
+This means that the Safe extension is more robust in the presence
+of mismatched versions of the perl executable and the Safe extension.
+
+=item op_mask
+
+This returns the operator mask which is actually in effect at the
+time the invocation to the subroutine is compiled. In general,
+this is probably not terribly useful.
+
+=back
+
+=head2 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+my $default_root = 'Root000000000';
+
+my $default_mask;
+
+sub new {
+    my($class, $root, $mask) = @_;
+    my $obj = {};
+    bless $obj, $class;
+    $obj->root(defined($root) ? $root : ("Safe::".$default_root++));
+    $obj->mask(defined($mask) ? $mask : $default_mask);
+    # 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->root . "::_"} = *_;
+    return $obj;
+}
+
+sub DESTROY {
+    my($obj) = @_;
+    my $root = $obj->root();
+    if ($root =~ /^Safe::(Root\d+)$/){
+	$root = $1;
+	delete $ {"Safe::"}{"$root\::"};
+    }
+}
+
+sub root {
+    my $obj = shift;
+    if (@_) {
+	$obj->{Root} = $_[0];
+    } else {
+	return $obj->{Root};
+    }
+}
+
+sub mask {
+    my $obj = shift;
+    if (@_) {
+	$obj->{Mask} = verify_mask($_[0]);
+    } else {
+	return $obj->{Mask};
+    }
+}
+
+sub verify_mask {
+    my($mask) = @_;
+    if (length($mask) != MAXO() || $mask !~ /^[\0\1]+$/) {
+	croak("argument is not a mask");
+    }
+    return $mask;
+}
+
+sub trap {
+    my $obj = shift;
+    $obj->setmaskel("\1", @_);
+}
+
+sub untrap {
+    my $obj = shift;
+    $obj->setmaskel("\0", @_);
+}
+
+sub emptymask { "\0" x MAXO() }
+sub fullmask { "\1" x MAXO() }
+
+sub setmaskel {
+    my $obj = shift;
+    my $val = shift;
+    croak("bad value for mask element") unless $val eq "\0" || $val eq "\1";
+    my $maskref = \$obj->{Mask};
+    my ($op, $opcode);
+    foreach $op (@_) {
+	$opcode = ($op =~ /^\d/) ? $op : opcode($op);
+	substr($$maskref, $opcode, 1) = $val;
+    }
+}
+
+sub share {
+    my $obj = shift;
+    my $root = $obj->root();
+    my ($arg);
+    foreach $arg (@_) {
+	my $var;
+	($var = $arg) =~ s/^(.)//;
+	my $caller = caller;
+	*{$root."::$var"} = ($1 eq '$') ? \${$caller."::$var"}
+			  : ($1 eq '@') ? \@{$caller."::$var"}
+			  : ($1 eq '%') ? \%{$caller."::$var"}
+			  : ($1 eq '*') ? *{$caller."::$var"}
+			  : ($1 eq '&') ? \&{$caller."::$var"}
+			  : croak(qq(No such variable type for "$1$var"));
+    }
+}
+
+sub varglob {
+    my ($obj, $var) = @_;
+    return *{$obj->root()."::$var"};
+}
+
+sub reval {
+    my ($obj, $expr) = @_;
+    my $root = $obj->{Root};
+    my $mask = $obj->{Mask};
+    verify_mask($mask);
+
+    my $evalsub = eval sprintf(<<'EOT', $root);
+	package %s;
+	sub {
+	    eval $expr;
+	}
+EOT
+    return safe_call_sv($root, $mask, $evalsub);
+}
+
+sub rdo {
+    my ($obj, $file) = @_;
+    my $root = $obj->{Root};
+    my $mask = $obj->{Mask};
+    verify_mask($mask);
+
+    $file =~ s/"/\\"/g; # just in case the filename contains any double quotes
+    my $evalsub = eval sprintf(<<'EOT', $root, $file);
+	package %s;
+	sub {
+	    do "%s";
+	}
+EOT
+    return safe_call_sv($root, $mask, $evalsub);
+}
+
+bootstrap Safe $VERSION;
+
+$default_mask = fullmask;
+my $name;
+while (defined ($name = <DATA>)) {
+    chomp $name;
+    next if $name =~ /^#/;
+    my $code = opcode($name);
+    substr($default_mask, $code, 1) = "\0";
+}
+
+1;
+
+__DATA__
+null
+stub
+scalar
+pushmark
+wantarray
+const
+gvsv
+gv
+gelem
+padsv
+padav
+padhv
+padany
+pushre
+rv2gv
+rv2sv
+av2arylen
+rv2cv
+anoncode
+prototype
+refgen
+srefgen
+ref
+bless
+glob
+readline
+rcatline
+regcmaybe
+regcomp
+match
+subst
+substcont
+trans
+sassign
+aassign
+chop
+schop
+chomp
+schomp
+defined
+undef
+study
+pos
+preinc
+i_preinc
+predec
+i_predec
+postinc
+i_postinc
+postdec
+i_postdec
+pow
+multiply
+i_multiply
+divide
+i_divide
+modulo
+i_modulo
+repeat
+add
+i_add
+subtract
+i_subtract
+concat
+stringify
+left_shift
+right_shift
+lt
+i_lt
+gt
+i_gt
+le
+i_le
+ge
+i_ge
+eq
+i_eq
+ne
+i_ne
+ncmp
+i_ncmp
+slt
+sgt
+sle
+sge
+seq
+sne
+scmp
+bit_and
+bit_xor
+bit_or
+negate
+i_negate
+not
+complement
+atan2
+sin
+cos
+rand
+srand
+exp
+log
+sqrt
+int
+hex
+oct
+abs
+length
+substr
+vec
+index
+rindex
+sprintf
+formline
+ord
+chr
+crypt
+ucfirst
+lcfirst
+uc
+lc
+quotemeta
+rv2av
+aelemfast
+aelem
+aslice
+each
+values
+keys
+delete
+exists
+rv2hv
+helem
+hslice
+split
+join
+list
+lslice
+anonlist
+anonhash
+splice
+push
+pop
+shift
+unshift
+reverse
+grepstart
+grepwhile
+mapstart
+mapwhile
+range
+flip
+flop
+and
+or
+xor
+cond_expr
+andassign
+orassign
+method
+entersub
+leavesub
+caller
+warn
+die
+reset
+lineseq
+nextstate
+dbstate
+unstack
+enter
+leave
+scope
+enteriter
+iter
+enterloop
+leaveloop
+return
+last
+next
+redo
+goto
+close
+fileno
+tie
+untie
+dbmopen
+dbmclose
+sselect
+select
+getc
+read
+enterwrite
+leavewrite
+prtf
+print
+sysread
+syswrite
+send
+recv
+eof
+tell
+seek
+truncate
+fcntl
+ioctl
+sockpair
+bind
+connect
+listen
+accept
+shutdown
+gsockopt
+ssockopt
+getsockname
+ftrwrite
+ftsvtx
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+alarm
+dofile
+entereval
+leaveeval
+entertry
+leavetry
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent