diff options
Diffstat (limited to 'contrib/perl5/ext/Opcode')
| -rw-r--r-- | contrib/perl5/ext/Opcode/Makefile.PL | 7 | ||||
| -rw-r--r-- | contrib/perl5/ext/Opcode/Opcode.pm | 575 | ||||
| -rw-r--r-- | contrib/perl5/ext/Opcode/Opcode.xs | 482 | ||||
| -rw-r--r-- | contrib/perl5/ext/Opcode/Safe.pm | 558 | ||||
| -rw-r--r-- | contrib/perl5/ext/Opcode/ops.pm | 45 |
5 files changed, 0 insertions, 1667 deletions
diff --git a/contrib/perl5/ext/Opcode/Makefile.PL b/contrib/perl5/ext/Opcode/Makefile.PL deleted file mode 100644 index d7e781f..0000000 --- a/contrib/perl5/ext/Opcode/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'Opcode', - MAN3PODS => {}, - VERSION_FROM => 'Opcode.pm', - XS_VERSION => '1.03' -); diff --git a/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm deleted file mode 100644 index 841120c..0000000 --- a/contrib/perl5/ext/Opcode/Opcode.pm +++ /dev/null @@ -1,575 +0,0 @@ -package Opcode; - -require 5.005_64; - -our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); - -$VERSION = "1.04"; -$XS_VERSION = "1.03"; - -use strict; -use Carp; -use Exporter (); -use XSLoader (); -@ISA = qw(Exporter); - -BEGIN { - @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 - <DATA>; - $/ = "\n="; # now read in 'pod section' chunks - while(<DATA>) { - 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<opcodes>. - -By default no opmask is in effect and any code can be compiled. - -The Opcode module allow you to define an I<operator mask> to be in -effect when perl I<next> 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<no warranty>, 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<do not use it>. - - -=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<opcode.h> 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<opset> 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<vice versa>. - -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<no> 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 existance of this optag a memory resource attack -may still be possible using only :base_core ops. - -Disabling these ops is a I<very> 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<filehandle> (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 - -=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<reasonable> 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<reasonable> 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 completness 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/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs deleted file mode 100644 index cc4e1f4..0000000 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ /dev/null @@ -1,482 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */ -#define OP_MASK_BUF_SIZE (MAXO + 100) - -/* XXX op_named_bits and opset_all are never freed */ -static HV *op_named_bits; /* cache shared for whole process */ -static SV *opset_all; /* mask with all bits set */ -static IV opset_len; /* length of opmasks in bytes */ -static int opcode_debug = 0; - -static SV *new_opset (pTHX_ SV *old_opset); -static int verify_opset (pTHX_ SV *opset, int fatal); -static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, char *opname); -static void put_op_bitspec (pTHX_ char *optag, STRLEN len, SV *opset); -static SV *get_op_bitspec (pTHX_ char *opname, STRLEN len, int fatal); - - -/* Initialise our private op_named_bits HV. - * It is first loaded with the name and number of each perl operator. - * Then the builtin tags :none and :all are added. - * Opcode.pm loads the standard optags from __DATA__ - * XXX leak-alert: data allocated here is never freed, call this - * at most once - */ - -static void -op_names_init(pTHX) -{ - int i; - STRLEN len; - char **op_names; - char *bitmap; - - op_named_bits = newHV(); - op_names = get_op_names(); - for(i=0; i < PL_maxo; ++i) { - SV *sv; - sv = newSViv(i); - SvREADONLY_on(sv); - hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0); - } - - put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv))); - - opset_all = new_opset(aTHX_ Nullsv); - bitmap = SvPV(opset_all, len); - i = len-1; /* deal with last byte specially, see below */ - while(i-- > 0) - bitmap[i] = 0xFF; - /* Take care to set the right number of bits in the last byte */ - bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; - put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */ -} - - -/* Store a new tag definition. Always a mask. - * The tag must not already be defined. - * SV *mask is copied not referenced. - */ - -static void -put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask) -{ - SV **svp; - verify_opset(aTHX_ mask,1); - if (!len) - len = strlen(optag); - svp = hv_fetch(op_named_bits, optag, len, 1); - if (SvOK(*svp)) - croak("Opcode tag \"%s\" already defined", optag); - sv_setsv(*svp, mask); - SvREADONLY_on(*svp); -} - - - -/* Fetch a 'bits' entry for an opname or optag (IV/PV). - * Note that we return the actual entry for speed. - * Always sv_mortalcopy() if returing it to user code. - */ - -static SV * -get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal) -{ - SV **svp; - if (!len) - len = strlen(opname); - svp = hv_fetch(op_named_bits, opname, len, 0); - if (!svp || !SvOK(*svp)) { - if (!fatal) - return Nullsv; - if (*opname == ':') - croak("Unknown operator tag \"%s\"", opname); - if (*opname == '!') /* XXX here later, or elsewhere? */ - croak("Can't negate operators here (\"%s\")", opname); - if (isALPHA(*opname)) - croak("Unknown operator name \"%s\"", opname); - croak("Unknown operator prefix \"%s\"", opname); - } - return *svp; -} - - - -static SV * -new_opset(pTHX_ SV *old_opset) -{ - SV *opset; - if (old_opset) { - verify_opset(aTHX_ old_opset,1); - opset = newSVsv(old_opset); - } - else { - opset = NEWSV(1156, opset_len); - Zero(SvPVX(opset), opset_len + 1, char); - SvCUR_set(opset, opset_len); - (void)SvPOK_only(opset); - } - /* not mortalised here */ - return opset; -} - - -static int -verify_opset(pTHX_ SV *opset, int fatal) -{ - char *err = Nullch; - if (!SvOK(opset)) err = "undefined"; - else if (!SvPOK(opset)) err = "wrong type"; - else if (SvCUR(opset) != opset_len) err = "wrong size"; - if (err && fatal) { - croak("Invalid opset: %s", err); - } - return !err; -} - - -static void -set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname) -{ - if (SvIOK(bitspec)) { - int myopcode = SvIV(bitspec); - int offset = myopcode >> 3; - int bit = myopcode & 0x07; - if (myopcode >= PL_maxo || myopcode < 0) - croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); - if (opcode_debug >= 2) - warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", - myopcode, offset, bit, opname, (on)?"on":"off"); - if (on) - bitmap[offset] |= 1 << bit; - else - bitmap[offset] &= ~(1 << bit); - } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { - - STRLEN len; - char *specbits = SvPV(bitspec, len); - if (opcode_debug >= 2) - warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off"); - if (on) - while(len-- > 0) bitmap[len] |= specbits[len]; - else - while(len-- > 0) bitmap[len] &= ~specbits[len]; - } - else - croak("panic: invalid bitspec for \"%s\" (type %u)", - opname, (unsigned)SvTYPE(bitspec)); -} - - -static void -opmask_add(pTHX_ SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ -{ - int i,j; - char *bitmask; - STRLEN len; - int myopcode = 0; - - verify_opset(aTHX_ opset,1); /* croaks on bad opset */ - - if (!PL_op_mask) /* caller must ensure PL_op_mask exists */ - croak("Can't add to uninitialised PL_op_mask"); - - /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */ - - bitmask = SvPV(opset, len); - for (i=0; i < opset_len; i++) { - U16 bits = bitmask[i]; - if (!bits) { /* optimise for sparse masks */ - myopcode += 8; - continue; - } - for (j=0; j < 8 && myopcode < PL_maxo; ) - PL_op_mask[myopcode++] |= bits & (1 << j++); - } -} - -static void -opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ -{ - char *orig_op_mask = PL_op_mask; - SAVEVPTR(PL_op_mask); -#if !defined(PERL_OBJECT) - /* XXX casting to an ordinary function ptr from a member function ptr - * is disallowed by Borland - */ - if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); -#endif - PL_op_mask = &op_mask_buf[0]; - if (orig_op_mask) - Copy(orig_op_mask, PL_op_mask, PL_maxo, char); - else - Zero(PL_op_mask, PL_maxo, char); - opmask_add(aTHX_ opset); -} - - - -MODULE = Opcode PACKAGE = Opcode - -PROTOTYPES: ENABLE - -BOOT: - assert(PL_maxo < OP_MASK_BUF_SIZE); - opset_len = (PL_maxo + 7) / 8; - if (opcode_debug >= 1) - warn("opset_len %ld\n", (long)opset_len); - op_names_init(aTHX); - - -void -_safe_call_sv(Package, mask, codesv) - char * Package - SV * mask - SV * codesv -PPCODE: - char op_mask_buf[OP_MASK_BUF_SIZE]; - GV *gv; - - ENTER; - - opmask_addlocal(aTHX_ mask, op_mask_buf); - - save_aptr(&PL_endav); - PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ - - save_hptr(&PL_defstash); /* save current default stash */ - /* the assignment to global defstash changes our sense of 'main' */ - PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ - save_hptr(&PL_curstash); - PL_curstash = PL_defstash; - - /* defstash must itself contain a main:: so we'll add that now */ - /* take care with the ref counts (was cause of long standing bug) */ - /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */ - gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV); - sv_free((SV*)GvHV(gv)); - GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); - - /* %INC must be clean for use/require in compartment */ - save_hash(PL_incgv); - sv_free((SV*)GvHV(PL_incgv)); /* get rid of what save_hash gave us*/ - GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); - - PUSHMARK(SP); - perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ - SPAGAIN; /* for the PUTBACK added by xsubpp */ - LEAVE; - - -int -verify_opset(opset, fatal = 0) - SV *opset - int fatal -CODE: - RETVAL = verify_opset(aTHX_ opset,fatal); -OUTPUT: - RETVAL - -void -invert_opset(opset) - SV *opset -CODE: - { - char *bitmap; - STRLEN len = opset_len; - opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */ - bitmap = SvPVX(opset); - while(len-- > 0) - bitmap[len] = ~bitmap[len]; - /* take care of extra bits beyond PL_maxo in last byte */ - if (PL_maxo & 07) - bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07)); - } - ST(0) = opset; - - -void -opset_to_ops(opset, desc = 0) - SV *opset - int desc -PPCODE: - { - STRLEN len; - int i, j, myopcode; - char *bitmap = SvPV(opset, len); - char **names = (desc) ? get_op_descs() : get_op_names(); - verify_opset(aTHX_ opset,1); - for (myopcode=0, i=0; i < opset_len; i++) { - U16 bits = bitmap[i]; - for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) { - if ( bits & (1 << j) ) - XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0))); - } - } - } - - -void -opset(...) -CODE: - int i; - SV *bitspec, *opset; - char *bitmap; - STRLEN len, on; - opset = sv_2mortal(new_opset(aTHX_ Nullsv)); - bitmap = SvPVX(opset); - for (i = 0; i < items; i++) { - char *opname; - on = 1; - if (verify_opset(aTHX_ ST(i),0)) { - opname = "(opset)"; - bitspec = ST(i); - } - else { - opname = SvPV(ST(i), len); - if (*opname == '!') { on=0; ++opname;--len; } - bitspec = get_op_bitspec(aTHX_ opname, len, 1); - } - set_opset_bits(aTHX_ bitmap, bitspec, on, opname); - } - ST(0) = opset; - - -#define PERMITING (ix == 0 || ix == 1) -#define ONLY_THESE (ix == 0 || ix == 2) - -void -permit_only(safe, ...) - SV *safe -ALIAS: - permit = 1 - deny_only = 2 - deny = 3 -CODE: - int i, on; - SV *bitspec, *mask; - char *bitmap, *opname; - STRLEN len; - - if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) - croak("Not a Safe object"); - mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); - if (ONLY_THESE) /* *_only = new mask, else edit current */ - sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); - else - verify_opset(aTHX_ mask,1); /* croaks */ - bitmap = SvPVX(mask); - for (i = 1; i < items; i++) { - on = PERMITING ? 0 : 1; /* deny = mask bit on */ - if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */ - opname = "(opset)"; - bitspec = ST(i); - } - else { /* it's an opname/optag */ - opname = SvPV(ST(i), len); - /* invert if op has ! prefix (only one allowed) */ - if (*opname == '!') { on = !on; ++opname; --len; } - bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */ - } - set_opset_bits(aTHX_ bitmap, bitspec, on, opname); - } - ST(0) = &PL_sv_yes; - - - -void -opdesc(...) -PPCODE: - int i, myopcode; - STRLEN len; - SV **args; - char **op_desc = get_op_descs(); - /* copy args to a scratch area since we may push output values onto */ - /* the stack faster than we read values off it if masks are used. */ - args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*)))); - for (i = 0; i < items; i++) { - char *opname = SvPV(args[i], len); - SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1); - if (SvIOK(bitspec)) { - myopcode = SvIV(bitspec); - if (myopcode < 0 || myopcode >= PL_maxo) - croak("panic: opcode %d (%s) out of range",myopcode,opname); - XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); - } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { - int b, j; - STRLEN n_a; - char *bitmap = SvPV(bitspec,n_a); - myopcode = 0; - for (b=0; b < opset_len; b++) { - U16 bits = bitmap[b]; - for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) - if (bits & (1 << j)) - XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); - } - } - else - croak("panic: invalid bitspec for \"%s\" (type %u)", - opname, (unsigned)SvTYPE(bitspec)); - } - - -void -define_optag(optagsv, mask) - SV *optagsv - SV *mask -CODE: - STRLEN len; - char *optag = SvPV(optagsv, len); - put_op_bitspec(aTHX_ optag, len, mask); /* croaks */ - ST(0) = &PL_sv_yes; - - -void -empty_opset() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); - -void -full_opset() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ opset_all)); - -void -opmask_add(opset) - SV *opset -PREINIT: - if (!PL_op_mask) - Newz(0, PL_op_mask, PL_maxo, char); -CODE: - opmask_add(aTHX_ opset); - -void -opcodes() -PPCODE: - if (GIMME == G_ARRAY) { - croak("opcodes in list context not yet implemented"); /* XXX */ - } - else { - XPUSHs(sv_2mortal(newSViv(PL_maxo))); - } - -void -opmask() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); - if (PL_op_mask) { - char *bitmap = SvPVX(ST(0)); - int myopcode; - for(myopcode=0; myopcode < PL_maxo; ++myopcode) { - if (PL_op_mask[myopcode]) - bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07); - } - } - diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm deleted file mode 100644 index 7e1d6a3..0000000 --- a/contrib/perl5/ext/Opcode/Safe.pm +++ /dev/null @@ -1,558 +0,0 @@ -package Safe; - -use 5.003_11; -use strict; - -our $VERSION = "2.06"; - -use Carp; - -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); - 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}; - - # 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__ - -=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<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 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<no warranty>, 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<do not use it>. - - -=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<addition> to any operators already permitted). - -=item permit_only (OP, ...) - -Permit I<only> the listed operators to be used when compiling code in -the compartment (I<no> 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<only> the listed operators from being used when compiling code -in the compartment (I<all> 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<Exporter(3)> -module. - -Each NAME must be the B<name> of a 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<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). The compartment's root package appears to be the -C<main::> 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 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()>. 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<all> 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<reval> 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 -E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. - -=cut - diff --git a/contrib/perl5/ext/Opcode/ops.pm b/contrib/perl5/ext/Opcode/ops.pm deleted file mode 100644 index 9b553b7..0000000 --- a/contrib/perl5/ext/Opcode/ops.pm +++ /dev/null @@ -1,45 +0,0 @@ -package ops; - -use Opcode qw(opmask_add opset invert_opset); - -sub import { - shift; - # Not that unimport is the prefered form since import's don't - # accumulate well owing to the 'only ever add opmask' rule. - # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected. - opmask_add(invert_opset opset(@_)) if @_; -} - -sub unimport { - shift; - opmask_add(opset(@_)) if @_; -} - -1; - -__END__ - -=head1 NAME - -ops - Perl pragma to restrict unsafe operations when compiling - -=head1 SYNOPSIS - - perl -Mops=:default ... # only allow reasonably safe operations - - perl -M-ops=system ... # disable the 'system' opcode - -=head1 DESCRIPTION - -Since the ops pragma currently has an irreversible global effect, it is -only of significant practical use with the C<-M> option on the command line. - -See the L<Opcode> module for information about opcodes, optags, opmasks -and important information about safety. - -=head1 SEE ALSO - -Opcode(3), Safe(3), perlrun(3) - -=cut - |
