From 021342e1fa503eed4693653c059ce9c97a5c105f Mon Sep 17 00:00:00 2001 From: Reinhard Kotucha Date: Sat, 19 Jul 2008 15:09:24 +0000 Subject: tlperl/lib: missing modules for perltex. git-svn-id: svn://tug.org/texlive/trunk@9667 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Opcode.pm | 578 +++++++++++++++ Master/tlpkg/tlperl/lib/POSIX.pm | 965 +++++++++++++++++++++++++ Master/tlpkg/tlperl/lib/Safe.pm | 576 +++++++++++++++ Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs | 0 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll | Bin 0 -> 21504 bytes 5 files changed, 2119 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/Opcode.pm create mode 100644 Master/tlpkg/tlperl/lib/POSIX.pm create mode 100644 Master/tlpkg/tlperl/lib/Safe.pm create mode 100644 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs create mode 100644 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll (limited to 'Master/tlpkg') diff --git a/Master/tlpkg/tlperl/lib/Opcode.pm b/Master/tlpkg/tlperl/lib/Opcode.pm new file mode 100644 index 00000000000..2987b9952e0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Opcode.pm @@ -0,0 +1,578 @@ +package Opcode; + +use 5.006_001; + +use strict; + +our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); + +$VERSION = "1.06"; +$XS_VERSION = "1.03"; + +use Carp; +use Exporter (); +use XSLoader (); + +BEGIN { + @ISA = qw(Exporter); + @EXPORT_OK = qw( + opset ops_to_opset + opset_to_ops opset_to_hex invert_opset + empty_opset full_opset + opdesc opcodes opmask define_optag + opmask_add verify_opset opdump + ); +} + +sub opset (;@); +sub opset_to_hex ($); +sub opdump (;$); +use subs @EXPORT_OK; + +XSLoader::load 'Opcode', $XS_VERSION; + +_init_optags(); + +sub ops_to_opset { opset @_ } # alias for old name + +sub opset_to_hex ($) { + return "(invalid opset)" unless verify_opset($_[0]); + unpack("h*",$_[0]); +} + +sub opdump (;$) { + my $pat = shift; + # handy utility: perl -MOpcode=opdump -e 'opdump File' + foreach(opset_to_ops(full_opset)) { + my $op = sprintf " %12s %s\n", $_, opdesc($_); + next if defined $pat and $op !~ m/$pat/i; + print $op; + } +} + + + +sub _init_optags { + my(%all, %seen); + @all{opset_to_ops(full_opset)} = (); # keys only + + local($_); + local($/) = "\n=cut"; # skip to optags definition section + ; + $/ = "\n="; # now read in 'pod section' chunks + while() { + next unless m/^item\s+(:\w+)/; + my $tag = $1; + + # Split into lines, keep only indented lines + my @lines = grep { m/^\s/ } split(/\n/); + foreach (@lines) { s/--.*// } # delete comments + my @ops = map { split ' ' } @lines; # get op words + + foreach(@ops) { + warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_}; + $seen{$_} = $tag; + delete $all{$_}; + } + # opset will croak on invalid names + define_optag($tag, opset(@ops)); + } + close(DATA); + warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all; +} + + +1; + +__DATA__ + +=head1 NAME + +Opcode - Disable named opcodes when compiling perl code + +=head1 SYNOPSIS + + use Opcode; + + +=head1 DESCRIPTION + +Perl code is always 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. +The internal format is based on many distinct I. + +By default no opmask is in effect and any code can be compiled. + +The Opcode module allow you to define an I to be in +effect when perl I compiles any code. Attempting to compile code +which contains a masked opcode will cause the compilation to fail +with an error. The code will not be executed. + +=head1 NOTE + +The Opcode module is not usually used directly. See the ops pragma and +Safe modules for more typical uses. + +=head1 WARNING + +The authors make B, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B. + + +=head1 Operator Names and Operator Lists + +The canonical list of operator names is the contents of the array +PL_op_name defined and initialised in file F of the Perl +source distribution (and installed into the perl library). + +Each operator has both a terse name (its opname) and a more verbose or +recognisable descriptive name. The opdesc function can be used to +return a list of descriptions for a list of operators. + +Many of the functions and methods listed below take a list of +operators as parameters. Most operator lists can be made up of several +types of element. Each element can be one of + +=over 8 + +=item an operator name (opname) + +Operator names are typically small lowercase words like enterloop, +leaveloop, last, next, redo etc. Sometimes they are rather cryptic +like gv2cv, i_ncmp and ftsvtx. + +=item an operator tag name (optag) + +Operator tags can be used to refer to groups (or sets) of operators. +Tag names always begin with a colon. The Opcode module defines several +optags and the user can define others using the define_optag function. + +=item a negated opname or optag + +An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir. +Negating an opname or optag means remove the corresponding ops from the +accumulated set of ops at that point. + +=item an operator set (opset) + +An I as a binary string of approximately 44 bytes which holds a +set or zero or more operators. + +The opset and opset_to_ops functions can be used to convert from +a list of operators to an opset and I. + +Wherever a list of operators can be given you can use one or more opsets. +See also Manipulating Opsets below. + +=back + + +=head1 Opcode Functions + +The Opcode package contains functions for manipulating operator names +tags and sets. All are available for export by the package. + +=over 8 + +=item opcodes + +In a scalar context opcodes returns the number of opcodes in this +version of perl (around 350 for perl-5.7.0). + +In a list context it returns a list of all the operator names. +(Not yet implemented, use @names = opset_to_ops(full_opset).) + +=item opset (OP, ...) + +Returns an opset containing the listed operators. + +=item opset_to_ops (OPSET) + +Returns a list of operator names corresponding to those operators in +the set. + +=item opset_to_hex (OPSET) + +Returns a string representation of an opset. Can be handy for debugging. + +=item full_opset + +Returns an opset which includes all operators. + +=item empty_opset + +Returns an opset which contains no operators. + +=item invert_opset (OPSET) + +Returns an opset which is the inverse set of the one supplied. + +=item verify_opset (OPSET, ...) + +Returns true if the supplied opset looks like a valid opset (is the +right length etc) otherwise it returns false. If an optional second +parameter is true then verify_opset will croak on an invalid opset +instead of returning false. + +Most of the other Opcode functions call verify_opset automatically +and will croak if given an invalid opset. + +=item define_optag (OPTAG, OPSET) + +Define OPTAG as a symbolic name for OPSET. Optag names always start +with a colon C<:>. + +The optag name used must not be defined already (define_optag will +croak if it is already defined). Optag names are global to the perl +process and optag definitions cannot be altered or deleted once +defined. + +It is strongly recommended that applications using Opcode should use a +leading capital letter on their tag names since lowercase names are +reserved for use by the Opcode module. If using Opcode within a module +you should prefix your tags names with the name of your module to +ensure uniqueness and thus avoid clashes with other modules. + +=item opmask_add (OPSET) + +Adds the supplied opset to the current opmask. Note that there is +currently I mechanism for unmasking ops once they have been masked. +This is intentional. + +=item opmask + +Returns an opset corresponding to the current opmask. + +=item opdesc (OP, ...) + +This takes a list of operator names and returns the corresponding list +of operator descriptions. + +=item opdump (PAT) + +Dumps to STDOUT a two column list of op names and op descriptions. +If an optional pattern is given then only lines which match the +(case insensitive) pattern will be output. + +It's designed to be used as a handy command line utility: + + perl -MOpcode=opdump -e opdump + perl -MOpcode=opdump -e 'opdump Eval' + +=back + +=head1 Manipulating Opsets + +Opsets may be manipulated using the perl bit vector operators & (and), | (or), +^ (xor) and ~ (negate/invert). + +However you should never rely on the numerical position of any opcode +within the opset. In other words both sides of a bit vector operator +should be opsets returned from Opcode functions. + +Also, since the number of opcodes in your current version of perl might +not be an exact multiple of eight, there may be unused bits in the last +byte of an upset. This should not cause any problems (Opcode functions +ignore those extra bits) but it does mean that using the ~ operator +will typically not produce the same 'physical' opset 'string' as the +invert_opset function. + + +=head1 TO DO (maybe) + + $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv + + $yes = opset_can($opset, @ops) true if $opset has all @ops set + + @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...) + +=cut + +# the =cut above is used by _init_optags() to get here quickly + +=head1 Predefined Opcode Tags + +=over 5 + +=item :base_core + + null stub scalar pushmark wantarray const defined undef + + rv2sv sassign + + rv2av aassign aelem aelemfast aslice av2arylen + + rv2hv helem hslice each values keys exists delete + + preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec + int hex oct abs pow multiply i_multiply divide i_divide + modulo i_modulo add i_add subtract i_subtract + + left_shift right_shift bit_and bit_xor bit_or negate i_negate + not complement + + 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 + + substr vec stringify study pos length index rindex ord chr + + ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp + + match split qr + + list lslice splice push pop shift unshift reverse + + cond_expr flip flop andassign orassign and or xor + + warn die lineseq nextstate scope enter leave setstate + + rv2cv anoncode prototype + + entersub leavesub leavesublv return method method_named -- XXX loops via recursion? + + leaveeval -- needed for Safe to operate, is safe without entereval + +=item :base_mem + +These memory related ops are not included in :base_core because they +can easily be used to implement a resource attack (e.g., consume all +available memory). + + concat repeat join range + + anonlist anonhash + +Note that despite the existence of this optag a memory resource attack +may still be possible using only :base_core ops. + +Disabling these ops is a I heavy handed way to attempt to prevent +a memory resource attack. It's probable that a specific memory limit +mechanism will be added to perl in the near future. + +=item :base_loop + +These loop ops are not included in :base_core because they can easily be +used to implement a resource attack (e.g., consume all available CPU time). + + grepstart grepwhile + mapstart mapwhile + enteriter iter + enterloop leaveloop unstack + last next redo + goto + +=item :base_io + +These ops enable I (rather than filename) based input and +output. These are safe on the assumption that only pre-existing +filehandles are available for use. To create new filehandles other ops +such as open would need to be enabled. + + readline rcatline getc read + + formline enterwrite leavewrite + + print sysread syswrite send recv + + eof tell seek sysseek + + readdir telldir seekdir rewinddir + +=item :base_orig + +These are a hotchpotch of opcodes still waiting to be considered + + gvsv gv gelem + + padsv padav padhv padany + + rv2gv refgen srefgen ref + + bless -- could be used to change ownership of objects (reblessing) + + pushre regcmaybe regcreset regcomp subst substcont + + sprintf prtf -- can core dump + + crypt + + tie untie + + dbmopen dbmclose + sselect select + pipe_op sockpair + + getppid getpgrp setpgrp getpriority setpriority localtime gmtime + + entertry leavetry -- can be used to 'hide' fatal errors + + custom -- where should this go + +=item :base_math + +These ops are not included in :base_core because of the risk of them being +used to generate floating point exceptions (which would have to be caught +using a $SIG{FPE} handler). + + atan2 sin cos exp log sqrt + +These ops are not included in :base_core because they have an effect +beyond the scope of the compartment. + + rand srand + +=item :base_thread + +These ops are related to multi-threading. + + lock threadsv + +=item :default + +A handy tag name for a I default set of ops. (The current ops +allowed are unstable while development continues. It will change.) + + :base_core :base_mem :base_loop :base_io :base_orig :base_thread + +If safety matters to you (and why else would you be using the Opcode module?) +then you should not rely on the definition of this, or indeed any other, optag! + + +=item :filesys_read + + stat lstat readlink + + ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread + ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned + ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx + + fttext ftbinary + + fileno + +=item :sys_db + + ghbyname ghbyaddr ghostent shostent ehostent -- hosts + gnbyname gnbyaddr gnetent snetent enetent -- networks + gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols + gsbyname gsbyport gservent sservent eservent -- services + + gpwnam gpwuid gpwent spwent epwent getlogin -- users + ggrnam ggrgid ggrent sgrent egrent -- groups + +=item :browse + +A handy tag name for a I default set of ops beyond the +:default optag. Like :default (and indeed all the other optags) its +current definition is unstable while development continues. It will change. + +The :browse tag represents the next step beyond :default. It it a +superset of the :default ops and adds :filesys_read the :sys_db. +The intent being that scripts can access more (possibly sensitive) +information about your system but not be able to change it. + + :default :filesys_read :sys_db + +=item :filesys_open + + sysopen open close + umask binmode + + open_dir closedir -- other dir ops are in :base_io + +=item :filesys_write + + link unlink rename symlink truncate + + mkdir rmdir + + utime chmod chown + + fcntl -- not strictly filesys related, but possibly as dangerous? + +=item :subprocess + + backtick system + + fork + + wait waitpid + + glob -- access to Cshell via <`rm *`> + +=item :ownprocess + + exec exit kill + + time tms -- could be used for timing attacks (paranoid?) + +=item :others + +This tag holds groups of assorted specialist opcodes that don't warrant +having optags defined for them. + +SystemV Interprocess Communications: + + msgctl msgget msgrcv msgsnd + + semctl semget semop + + shmctl shmget shmread shmwrite + +=item :still_to_be_decided + + chdir + flock ioctl + + socket getpeername ssockopt + bind connect listen accept shutdown gsockopt getsockname + + sleep alarm -- changes global timer state and signal handling + sort -- assorted problems including core dumps + tied -- can be used to access object implementing a tie + pack unpack -- can be used to create/use memory pointers + + entereval -- can be used to hide code from initial compile + require dofile + + caller -- get info about calling environment and args + + reset + + dbstate -- perl -d version of nextstate(ment) opcode + +=item :dangerous + +This tag is simply a bucket for opcodes that are unlikely to be used via +a tag name but need to be tagged for completeness and documentation. + + syscall dump chroot + + +=back + +=head1 SEE ALSO + +ops(3) -- perl pragma interface to Opcode module. + +Safe(3) -- Opcode and namespace limited execution compartments + +=head1 AUTHORS + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk as part of Safe version 1. + +Split out from Safe module version 1, named opcode tags and other +changes added by Tim Bunce. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/POSIX.pm b/Master/tlpkg/tlperl/lib/POSIX.pm new file mode 100644 index 00000000000..87676215e73 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/POSIX.pm @@ -0,0 +1,965 @@ +package POSIX; + +our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = (); + +our $VERSION = "1.09"; + +use AutoLoader; + +use XSLoader (); + +# Grandfather old foo_h form to new :foo_h form +my $loaded; + +sub import { + load_imports() unless $loaded++; + my $this = shift; + my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; + local $Exporter::ExportLevel = 1; + Exporter::import($this,@list); +} + +sub croak { require Carp; goto &Carp::croak } +# declare usage to assist AutoLoad +sub usage; + +XSLoader::load 'POSIX', $VERSION; + +my %NON_CONSTS = (map {($_,1)} + qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS + WIFEXITED WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG)); + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + # require AutoLoader; + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + local $! = 0; + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + if ($NON_CONSTS{$constname}) { + my ($val, $error) = &int_macro_int($constname, $_[0]); + croak $error if $error; + *$AUTOLOAD = sub { &int_macro_int($constname, $_[0]) }; + } else { + my ($error, $val) = constant($constname); + croak $error if $error; + *$AUTOLOAD = sub { $val }; + } + + goto &$AUTOLOAD; +} + +package POSIX::SigAction; + +use AutoLoader 'AUTOLOAD'; +sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] } + +package POSIX; + +1; +__END__ + +sub usage { + my ($mess) = @_; + croak "Usage: POSIX::$mess"; +} + +sub redef { + my ($mess) = @_; + croak "Use method $mess instead"; +} + +sub unimpl { + my ($mess) = @_; + $mess =~ s/xxx//; + croak "Unimplemented: POSIX::$mess"; +} + +sub assert { + usage "assert(expr)" if @_ != 1; + if (!$_[0]) { + croak "Assertion failed"; + } +} + +sub tolower { + usage "tolower(string)" if @_ != 1; + lc($_[0]); +} + +sub toupper { + usage "toupper(string)" if @_ != 1; + uc($_[0]); +} + +sub closedir { + usage "closedir(dirhandle)" if @_ != 1; + CORE::closedir($_[0]); +} + +sub opendir { + usage "opendir(directory)" if @_ != 1; + my $dirhandle; + CORE::opendir($dirhandle, $_[0]) + ? $dirhandle + : undef; +} + +sub readdir { + usage "readdir(dirhandle)" if @_ != 1; + CORE::readdir($_[0]); +} + +sub rewinddir { + usage "rewinddir(dirhandle)" if @_ != 1; + CORE::rewinddir($_[0]); +} + +sub errno { + usage "errno()" if @_ != 0; + $! + 0; +} + +sub creat { + usage "creat(filename, mode)" if @_ != 2; + &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]); +} + +sub fcntl { + usage "fcntl(filehandle, cmd, arg)" if @_ != 3; + CORE::fcntl($_[0], $_[1], $_[2]); +} + +sub getgrgid { + usage "getgrgid(gid)" if @_ != 1; + CORE::getgrgid($_[0]); +} + +sub getgrnam { + usage "getgrnam(name)" if @_ != 1; + CORE::getgrnam($_[0]); +} + +sub atan2 { + usage "atan2(x,y)" if @_ != 2; + CORE::atan2($_[0], $_[1]); +} + +sub cos { + usage "cos(x)" if @_ != 1; + CORE::cos($_[0]); +} + +sub exp { + usage "exp(x)" if @_ != 1; + CORE::exp($_[0]); +} + +sub fabs { + usage "fabs(x)" if @_ != 1; + CORE::abs($_[0]); +} + +sub log { + usage "log(x)" if @_ != 1; + CORE::log($_[0]); +} + +sub pow { + usage "pow(x,exponent)" if @_ != 2; + $_[0] ** $_[1]; +} + +sub sin { + usage "sin(x)" if @_ != 1; + CORE::sin($_[0]); +} + +sub sqrt { + usage "sqrt(x)" if @_ != 1; + CORE::sqrt($_[0]); +} + +sub getpwnam { + usage "getpwnam(name)" if @_ != 1; + CORE::getpwnam($_[0]); +} + +sub getpwuid { + usage "getpwuid(uid)" if @_ != 1; + CORE::getpwuid($_[0]); +} + +sub longjmp { + unimpl "longjmp() is C-specific: use die instead"; +} + +sub setjmp { + unimpl "setjmp() is C-specific: use eval {} instead"; +} + +sub siglongjmp { + unimpl "siglongjmp() is C-specific: use die instead"; +} + +sub sigsetjmp { + unimpl "sigsetjmp() is C-specific: use eval {} instead"; +} + +sub kill { + usage "kill(pid, sig)" if @_ != 2; + CORE::kill $_[1], $_[0]; +} + +sub raise { + usage "raise(sig)" if @_ != 1; + CORE::kill $_[0], $$; # Is this good enough? +} + +sub offsetof { + unimpl "offsetof() is C-specific, stopped"; +} + +sub clearerr { + redef "IO::Handle::clearerr()"; +} + +sub fclose { + redef "IO::Handle::close()"; +} + +sub fdopen { + redef "IO::Handle::new_from_fd()"; +} + +sub feof { + redef "IO::Handle::eof()"; +} + +sub fgetc { + redef "IO::Handle::getc()"; +} + +sub fgets { + redef "IO::Handle::gets()"; +} + +sub fileno { + redef "IO::Handle::fileno()"; +} + +sub fopen { + redef "IO::File::open()"; +} + +sub fprintf { + unimpl "fprintf() is C-specific--use printf instead"; +} + +sub fputc { + unimpl "fputc() is C-specific--use print instead"; +} + +sub fputs { + unimpl "fputs() is C-specific--use print instead"; +} + +sub fread { + unimpl "fread() is C-specific--use read instead"; +} + +sub freopen { + unimpl "freopen() is C-specific--use open instead"; +} + +sub fscanf { + unimpl "fscanf() is C-specific--use <> and regular expressions instead"; +} + +sub fseek { + redef "IO::Seekable::seek()"; +} + +sub fsync { + redef "IO::Handle::sync()"; +} + +sub ferror { + redef "IO::Handle::error()"; +} + +sub fflush { + redef "IO::Handle::flush()"; +} + +sub fgetpos { + redef "IO::Seekable::getpos()"; +} + +sub fsetpos { + redef "IO::Seekable::setpos()"; +} + +sub ftell { + redef "IO::Seekable::tell()"; +} + +sub fwrite { + unimpl "fwrite() is C-specific--use print instead"; +} + +sub getc { + usage "getc(handle)" if @_ != 1; + CORE::getc($_[0]); +} + +sub getchar { + usage "getchar()" if @_ != 0; + CORE::getc(STDIN); +} + +sub gets { + usage "gets()" if @_ != 0; + scalar ; +} + +sub perror { + print STDERR "@_: " if @_; + print STDERR $!,"\n"; +} + +sub printf { + usage "printf(pattern, args...)" if @_ < 1; + CORE::printf STDOUT @_; +} + +sub putc { + unimpl "putc() is C-specific--use print instead"; +} + +sub putchar { + unimpl "putchar() is C-specific--use print instead"; +} + +sub puts { + unimpl "puts() is C-specific--use print instead"; +} + +sub remove { + usage "remove(filename)" if @_ != 1; + CORE::unlink($_[0]); +} + +sub rename { + usage "rename(oldfilename, newfilename)" if @_ != 2; + CORE::rename($_[0], $_[1]); +} + +sub rewind { + usage "rewind(filehandle)" if @_ != 1; + CORE::seek($_[0],0,0); +} + +sub scanf { + unimpl "scanf() is C-specific--use <> and regular expressions instead"; +} + +sub sprintf { + usage "sprintf(pattern,args)" if @_ == 0; + CORE::sprintf(shift,@_); +} + +sub sscanf { + unimpl "sscanf() is C-specific--use regular expressions instead"; +} + +sub tmpfile { + redef "IO::File::new_tmpfile()"; +} + +sub ungetc { + redef "IO::Handle::ungetc()"; +} + +sub vfprintf { + unimpl "vfprintf() is C-specific"; +} + +sub vprintf { + unimpl "vprintf() is C-specific"; +} + +sub vsprintf { + unimpl "vsprintf() is C-specific"; +} + +sub abs { + usage "abs(x)" if @_ != 1; + CORE::abs($_[0]); +} + +sub atexit { + unimpl "atexit() is C-specific: use END {} instead"; +} + +sub atof { + unimpl "atof() is C-specific, stopped"; +} + +sub atoi { + unimpl "atoi() is C-specific, stopped"; +} + +sub atol { + unimpl "atol() is C-specific, stopped"; +} + +sub bsearch { + unimpl "bsearch() not supplied"; +} + +sub calloc { + unimpl "calloc() is C-specific, stopped"; +} + +sub div { + unimpl "div() is C-specific, use /, % and int instead"; +} + +sub exit { + usage "exit(status)" if @_ != 1; + CORE::exit($_[0]); +} + +sub free { + unimpl "free() is C-specific, stopped"; +} + +sub getenv { + usage "getenv(name)" if @_ != 1; + $ENV{$_[0]}; +} + +sub labs { + unimpl "labs() is C-specific, use abs instead"; +} + +sub ldiv { + unimpl "ldiv() is C-specific, use /, % and int instead"; +} + +sub malloc { + unimpl "malloc() is C-specific, stopped"; +} + +sub qsort { + unimpl "qsort() is C-specific, use sort instead"; +} + +sub rand { + unimpl "rand() is non-portable, use Perl's rand instead"; +} + +sub realloc { + unimpl "realloc() is C-specific, stopped"; +} + +sub srand { + unimpl "srand()"; +} + +sub system { + usage "system(command)" if @_ != 1; + CORE::system($_[0]); +} + +sub memchr { + unimpl "memchr() is C-specific, use index() instead"; +} + +sub memcmp { + unimpl "memcmp() is C-specific, use eq instead"; +} + +sub memcpy { + unimpl "memcpy() is C-specific, use = instead"; +} + +sub memmove { + unimpl "memmove() is C-specific, use = instead"; +} + +sub memset { + unimpl "memset() is C-specific, use x instead"; +} + +sub strcat { + unimpl "strcat() is C-specific, use .= instead"; +} + +sub strchr { + unimpl "strchr() is C-specific, use index() instead"; +} + +sub strcmp { + unimpl "strcmp() is C-specific, use eq instead"; +} + +sub strcpy { + unimpl "strcpy() is C-specific, use = instead"; +} + +sub strcspn { + unimpl "strcspn() is C-specific, use regular expressions instead"; +} + +sub strerror { + usage "strerror(errno)" if @_ != 1; + local $! = $_[0]; + $! . ""; +} + +sub strlen { + unimpl "strlen() is C-specific, use length instead"; +} + +sub strncat { + unimpl "strncat() is C-specific, use .= instead"; +} + +sub strncmp { + unimpl "strncmp() is C-specific, use eq instead"; +} + +sub strncpy { + unimpl "strncpy() is C-specific, use = instead"; +} + +sub strpbrk { + unimpl "strpbrk() is C-specific, stopped"; +} + +sub strrchr { + unimpl "strrchr() is C-specific, use rindex() instead"; +} + +sub strspn { + unimpl "strspn() is C-specific, stopped"; +} + +sub strstr { + usage "strstr(big, little)" if @_ != 2; + CORE::index($_[0], $_[1]); +} + +sub strtok { + unimpl "strtok() is C-specific, stopped"; +} + +sub chmod { + usage "chmod(mode, filename)" if @_ != 2; + CORE::chmod($_[0], $_[1]); +} + +sub fstat { + usage "fstat(fd)" if @_ != 1; + local *TMP; + CORE::open(TMP, "<&$_[0]"); # Gross. + my @l = CORE::stat(TMP); + CORE::close(TMP); + @l; +} + +sub mkdir { + usage "mkdir(directoryname, mode)" if @_ != 2; + CORE::mkdir($_[0], $_[1]); +} + +sub stat { + usage "stat(filename)" if @_ != 1; + CORE::stat($_[0]); +} + +sub umask { + usage "umask(mask)" if @_ != 1; + CORE::umask($_[0]); +} + +sub wait { + usage "wait()" if @_ != 0; + CORE::wait(); +} + +sub waitpid { + usage "waitpid(pid, options)" if @_ != 2; + CORE::waitpid($_[0], $_[1]); +} + +sub gmtime { + usage "gmtime(time)" if @_ != 1; + CORE::gmtime($_[0]); +} + +sub localtime { + usage "localtime(time)" if @_ != 1; + CORE::localtime($_[0]); +} + +sub time { + usage "time()" if @_ != 0; + CORE::time; +} + +sub alarm { + usage "alarm(seconds)" if @_ != 1; + CORE::alarm($_[0]); +} + +sub chdir { + usage "chdir(directory)" if @_ != 1; + CORE::chdir($_[0]); +} + +sub chown { + usage "chown(uid, gid, filename)" if @_ != 3; + CORE::chown($_[0], $_[1], $_[2]); +} + +sub execl { + unimpl "execl() is C-specific, stopped"; +} + +sub execle { + unimpl "execle() is C-specific, stopped"; +} + +sub execlp { + unimpl "execlp() is C-specific, stopped"; +} + +sub execv { + unimpl "execv() is C-specific, stopped"; +} + +sub execve { + unimpl "execve() is C-specific, stopped"; +} + +sub execvp { + unimpl "execvp() is C-specific, stopped"; +} + +sub fork { + usage "fork()" if @_ != 0; + CORE::fork; +} + +sub getegid { + usage "getegid()" if @_ != 0; + $) + 0; +} + +sub geteuid { + usage "geteuid()" if @_ != 0; + $> + 0; +} + +sub getgid { + usage "getgid()" if @_ != 0; + $( + 0; +} + +sub getgroups { + usage "getgroups()" if @_ != 0; + my %seen; + grep(!$seen{$_}++, split(' ', $) )); +} + +sub getlogin { + usage "getlogin()" if @_ != 0; + CORE::getlogin(); +} + +sub getpgrp { + usage "getpgrp()" if @_ != 0; + CORE::getpgrp; +} + +sub getpid { + usage "getpid()" if @_ != 0; + $$; +} + +sub getppid { + usage "getppid()" if @_ != 0; + CORE::getppid; +} + +sub getuid { + usage "getuid()" if @_ != 0; + $<; +} + +sub isatty { + usage "isatty(filehandle)" if @_ != 1; + -t $_[0]; +} + +sub link { + usage "link(oldfilename, newfilename)" if @_ != 2; + CORE::link($_[0], $_[1]); +} + +sub rmdir { + usage "rmdir(directoryname)" if @_ != 1; + CORE::rmdir($_[0]); +} + +sub setbuf { + redef "IO::Handle::setbuf()"; +} + +sub setvbuf { + redef "IO::Handle::setvbuf()"; +} + +sub sleep { + usage "sleep(seconds)" if @_ != 1; + $_[0] - CORE::sleep($_[0]); +} + +sub unlink { + usage "unlink(filename)" if @_ != 1; + CORE::unlink($_[0]); +} + +sub utime { + usage "utime(filename, atime, mtime)" if @_ != 3; + CORE::utime($_[1], $_[2], $_[0]); +} + +sub load_imports { +%EXPORT_TAGS = ( + + assert_h => [qw(assert NDEBUG)], + + ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)], + + dirent_h => [], + + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], + + fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)], + + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], + + grp_h => [], + + limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], + + locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES + LC_MONETARY LC_NUMERIC LC_TIME NULL + localeconv setlocale)], + + math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], + + pwd_h => [], + + setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], + + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], + + stdarg_h => [], + + stddef_h => [qw(NULL offsetof)], + + stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + STREAM_MAX TMP_MAX stderr stdin stdout + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)], + + stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX + abort atexit atof atoi atol bsearch calloc div + free getenv labs ldiv malloc mblen mbstowcs mbtowc + qsort realloc strtod strtol strtoul wcstombs wctomb)], + + string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)], + + sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)], + + sys_times_h => [], + + sys_types_h => [], + + sys_utsname_h => [qw(uname)], + + sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], + + termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )], + + time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)], + + unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf fsync getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], + + utime_h => [], + +); + +# Exporter::export_tags(); +for (values %EXPORT_TAGS) { + push @EXPORT, @$_; +} + +@EXPORT_OK = qw( + abs + alarm + atan2 + chdir + chmod + chown + close + closedir + cos + exit + exp + fcntl + fileno + fork + getc + getgrgid + getgrnam + getlogin + getpgrp + getppid + getpwnam + getpwuid + gmtime + isatty + kill + lchown + link + localtime + log + mkdir + nice + open + opendir + pipe + printf + rand + read + readdir + rename + rewinddir + rmdir + sin + sleep + sprintf + sqrt + srand + stat + system + time + times + umask + unlink + utime + wait + waitpid + write +); + +require Exporter; +} + +package POSIX::SigAction; + +sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} }; +sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} }; +sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} }; +sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} }; diff --git a/Master/tlpkg/tlperl/lib/Safe.pm b/Master/tlpkg/tlperl/lib/Safe.pm new file mode 100644 index 00000000000..e2a608023ca --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Safe.pm @@ -0,0 +1,576 @@ +package Safe; + +use 5.003_11; +use strict; + +$Safe::VERSION = "2.12"; + +# *** Don't declare any lexicals above this point *** +# +# This function should return a closure which contains an eval that can't +# see any lexicals in scope (apart from __ExPr__ which is unavoidable) + +sub lexless_anon_sub { + # $_[0] is package; + # $_[1] is strict flag; + my $__ExPr__ = $_[2]; # must be a lexical to create the closure that + # can be used to pass the value into the safe + # world + + # 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) + eval sprintf + 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }', + $_[0], $_[1] ? 'use' : 'no'; +} + +use Carp; +use Carp::Heavy; + +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 + + +my $default_root = 0; +my $default_share = ['*_']; #, '*main::']; + +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; + } + + # 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'); + + # 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}) if($Opcode::VERSION > 1.04); + return $obj; +} + +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\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + # The 'my $foo' is needed! Without it you get an + # 'Attempt to free unreferenced scalar' warning! + my $stem_symtab = *{$stem}{HASH}; + + #warn "erase($pkg) stem=$stem, leaf=$leaf"; + #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; + # ", join(', ', %$stem_symtab),"\n"; + +# delete $stem_symtab->{$leaf}; + + my $leaf_glob = $stem_symtab->{$leaf}; + my $leaf_symtab = *{$leaf_glob}{HASH}; +# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; + %$leaf_symtab = (); + #delete $leaf_symtab->{'__ANON__'}; + #delete $leaf_symtab->{'foo'}; + #delete $leaf_symtab->{'main::'}; +# my $foo = undef ${"$stem\::"}{"$leaf\::"}; + + 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}; + + my $evalsub = lexless_anon_sub($root,$strict, $expr); + 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__ + +=head1 NAME + +Safe - Compile and execute code in restricted compartments + +=head1 SYNOPSIS + + use Safe; + + $compartment = new Safe; + + $compartment->permit(qw(time sort :browse)); + + $result = $compartment->reval($unsafe_code); + +=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 I 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 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 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 Opcode(3) 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 + } + $cpt->share('&wrapper'); + +=back + + +=head1 WARNING + +The authors make B, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B. + + +=head2 RECENT CHANGES + +The interface to the Safe module has changed quite dramatically since +version 1 (as supplied with Perl5.002). Study these pages carefully if +you have code written to use Safe version 1 because you will need to +makes changes. + + +=head2 Methods in class Safe + +To create a new compartment, use + + $cpt = new Safe; + +Optional argument is (NAMESPACE), where NAMESPACE is the root namespace +to use for the compartment (defaults to "Safe::Root0", incremented for +each new compartment). + +Note that version 1.00 of the Safe module supported a second optional +parameter, MASK. That functionality has been withdrawn pending deeper +consideration. Use the permit and deny methods described below. + +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 permit (OP, ...) + +Permit the listed operators to be used when compiling code in the +compartment (in I to any operators already permitted). + +You can list opcodes by names, or use a tag name; see +L. + +=item permit_only (OP, ...) + +Permit I the listed operators to be used when compiling code in +the compartment (I other operators are permitted). + +=item deny (OP, ...) + +Deny the listed operators from being used when compiling code in the +compartment (other operators may still be permitted). + +=item deny_only (OP, ...) + +Deny I the listed operators from being used when compiling code +in the compartment (I other operators will be permitted). + +=item trap (OP, ...) + +=item untrap (OP, ...) + +The trap and untrap methods are synonyms for deny and permit +respectfully. + +=item share (NAME, ...) + +This shares the variable(s) in the argument list with the compartment. +This is almost identical to exporting variables using the L +module. + +Each NAME must be the B of a non-lexical variable, typically +with the leading type identifier included. A bareword is treated as a +function name. + +Examples of legal names are '$foo' for a scalar, '@foo' for an +array, '%foo' for a hash, '&foo' or '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). + +Each NAME is assumed to be in the calling package. See share_from +for an alternative method (which share uses). + +=item share_from (PACKAGE, ARRAYREF) + +This method is similar to share() but allows you to explicitly name the +package that symbols should be shared from. The symbol names (including +type characters) are supplied as an array reference. + + $safe->share_from('main', [ '$foo', '%bar', 'func' ]); + + +=item varglob (VARNAME) + +This returns a glob reference for the symbol table entry of VARNAME in +the package of the compartment. VARNAME must be the B 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 method). The compartment's root package appears to be the +C package to the code inside the compartment. + +Any attempt by the code in STRING to use an operator which is not permitted +by the compartment 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...". + +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. The context (list or scalar) is determined +by the caller as usual. + +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 and the context was always scalar. + +Some points to note: + +If the entereval op is permitted then the code can use eval "..." to +'hide' code which might use denied ops. This is not a major problem +since when the code tries to execute the eval it will fail because the +opmask is still in effect. However this technique would allow clever, +and possibly harmful, code to 'probe' the boundaries of what is +possible. + +Any string eval which is executed by code executing in a compartment, +or by code called from code executing in a compartment, will be eval'd +in the namespace of the compartment. This is potentially a serious +problem. + +Consider a function foo() in package pkg compiled outside a compartment +but shared with it. Assume the compartment has a root package called +'Root'. If foo() contains an eval statement like eval '$foo = 1' then, +normally, $pkg::foo will be set to 1. If foo() is called from the +compartment (by whatever means) then instead of setting $pkg::foo, the +eval will actually set $Root::pkg::foo. + +This can easily be demonstrated by using a module, such as the Socket +module, which uses eval "..." as part of an AUTOLOAD function. You can +'use' the module outside the compartment and share an (autoloaded) +function with the compartment. If an autoload is triggered by code in +the compartment, or by any code anywhere that is called by any means +from the compartment, then the eval in the Socket module's AUTOLOAD +function happens in the namespace of the compartment. Any variables +created or used by the eval'd code are now under the control of +the code in the compartment. + +A similar effect applies to I runtime symbol lookups in code +called from a compartment but not compiled within it. + + + +=item rdo (FILENAME) + +This evaluates the contents of file FILENAME inside the compartment. +See above documentation on the B method for further details. + +=item root (NAMESPACE) + +This method returns the name of the package that is the root of the +compartment's namespace. + +Note that this behaviour differs from version 1.00 of the Safe module +where the root module could be used to change the namespace. That +functionality has been withdrawn pending deeper consideration. + +=item mask (MASK) + +This is a get-or-set method for the compartment's operator mask. + +With no MASK argument present, it returns the current operator mask of +the compartment. + +With the MASK argument present, it sets the operator mask for the +compartment (equivalent to calling the deny_only method). + +=back + + +=head2 Some Safety Issues + +This section is currently just an outline of some of the things code in +a compartment might do (intentionally or unintentionally) which can +have an effect outside the compartment. + +=over 8 + +=item Memory + +Consuming all (or nearly all) available memory. + +=item CPU + +Causing infinite loops etc. + +=item Snooping + +Copying private information out of your system. Even something as +simple as your user name is of value to others. Much useful information +could be gleaned from your environment variables for example. + +=item Signals + +Causing signals (especially SIGFPE and SIGALARM) to affect your process. + +Setting up a signal handler will need to be carefully considered +and controlled. What mask is in effect when a signal handler +gets called? If a user can get an imported function to get an +exception and call the user's signal handler, does that user's +restricted mask get re-instated before the handler is called? +Does an imported handler get called with its original mask or +the user's one? + +=item State Changes + +Ops such as chdir obviously effect the process as a whole and not just +the code in the compartment. Ops such as rand and srand have a similar +but more subtle effect. + +=back + +=head2 AUTHOR + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk. + +Reworked to use the Opcode module and other changes added by Tim Bunce +EFE. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs b/Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs new file mode 100644 index 00000000000..e69de29bb2d diff --git a/Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll b/Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll new file mode 100644 index 00000000000..d44ff0069b8 Binary files /dev/null and b/Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll differ -- cgit v1.2.3