dslinux/user/perl/ext/Opcode Makefile.PL Opcode.pm Opcode.xs Safe.pm ops.pm
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:37 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/Opcode
In directory antilope:/tmp/cvs-serv17422/ext/Opcode
Added Files:
Makefile.PL Opcode.pm Opcode.xs Safe.pm ops.pm
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: ops.pm ---
package ops;
our $VERSION = '1.01';
use Opcode qw(opmask_add opset invert_opset);
sub import {
shift;
# Not that unimport is the preferred 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
--- NEW FILE: Opcode.xs ---
#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 */
#define MY_CXT_KEY "Opcode::_guts" XS_VERSION
typedef struct {
HV * x_op_named_bits; /* cache shared for whole process */
SV * x_opset_all; /* mask with all bits set */
IV x_opset_len; /* length of opmasks in bytes */
int x_opcode_debug;
} my_cxt_t;
START_MY_CXT
#define op_named_bits (MY_CXT.x_op_named_bits)
#define opset_all (MY_CXT.x_opset_all)
#define opset_len (MY_CXT.x_opset_len)
#define opcode_debug (MY_CXT.x_opcode_debug)
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, const char *opname);
static void put_op_bitspec (pTHX_ const char *optag, STRLEN len, SV *opset);
static SV *get_op_bitspec (pTHX_ const 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;
dMY_CXT;
op_named_bits = newHV();
op_names = get_op_names();
for(i=0; i < PL_maxo; ++i) {
SV * const 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] = (char)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_ const char *optag, STRLEN len, SV *mask)
{
SV **svp;
dMY_CXT;
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_ const char *opname, STRLEN len, int fatal)
{
SV **svp;
dMY_CXT;
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;
dMY_CXT;
if (old_opset) {
verify_opset(aTHX_ old_opset,1);
opset = newSVsv(old_opset);
}
else {
opset = NEWSV(1156, opset_len);
Zero(SvPVX_const(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)
{
const char *err = Nullch;
dMY_CXT;
if (!SvOK(opset)) err = "undefined";
else if (!SvPOK(opset)) err = "wrong type";
else if (SvCUR(opset) != (STRLEN)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, const char *opname)
{
dMY_CXT;
if (SvIOK(bitspec)) {
const int myopcode = SvIV(bitspec);
const int offset = myopcode >> 3;
const 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) == (STRLEN)opset_len) {
STRLEN len;
const char * const 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;
dMY_CXT;
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++) {
const 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;
dMY_CXT;
SAVEVPTR(PL_op_mask);
/* 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");
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:
{
MY_CXT_INIT;
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_pkg_prep(Package)
const char *Package
PPCODE:
HV *hv;
ENTER;
hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already */
if (strNE(HvNAME_get(hv),"main")) {
/* make it think it's in main:: */
hv_name_set(hv, "main", 4, 0);
hv_store(hv,"_",1,(SV *)PL_defgv,0); /* connect _ to global */
SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */
}
LEAVE;
void
_safe_call_sv(Package, mask, codesv)
char * Package
SV * mask
SV * codesv
PPCODE:
char op_mask_buf[OP_MASK_BUF_SIZE];
GV *gv;
HV *dummy_hv;
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 */
dummy_hv = save_hash(PL_incgv);
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 */
sv_free( (SV *) dummy_hv); /* get rid of what save_hash gave us*/
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;
dMY_CXT;
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;
const char * const bitmap = SvPV(opset, len);
char **names = (desc) ? get_op_descs() : get_op_names();
dMY_CXT;
verify_opset(aTHX_ opset,1);
for (myopcode=0, i=0; i < opset_len; i++) {
const 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;
STRLEN len, on;
SV * const opset = sv_2mortal(new_opset(aTHX_ Nullsv));
char * const bitmap = SvPVX(opset);
for (i = 0; i < items; i++) {
const 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;
SV *bitspec, *mask;
char *bitmap;
STRLEN len;
dMY_CXT;
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++) {
const char *opname;
int 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;
STRLEN len;
SV **args;
char **op_desc = get_op_descs();
dMY_CXT;
/* 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++) {
const char * const opname = SvPV(args[i], len);
SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1);
if (SvIOK(bitspec)) {
const int 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) == (STRLEN)opset_len) {
int b, j;
const char * const bitmap = SvPV_nolen_const(bitspec);
int myopcode = 0;
for (b=0; b < opset_len; b++) {
const 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;
const 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:
dMY_CXT;
ST(0) = sv_2mortal(new_opset(aTHX_ opset_all));
void
opmask_add(opset)
SV *opset
PREINIT:
if (!PL_op_mask)
Newxz(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 * const bitmap = SvPVX(ST(0));
int myopcode;
for(myopcode=0; myopcode < PL_maxo; ++myopcode) {
if (PL_op_mask[myopcode])
bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
}
}
--- NEW FILE: Opcode.pm ---
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
<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 existence 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
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<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 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 at 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
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Opcode',
MAN3PODS => {},
VERSION_FROM => 'Opcode.pm',
XS_VERSION => '1.03'
);
--- NEW FILE: Safe.pm ---
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<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).
You can list opcodes by names, or use a tag name; see
L<Opcode/"Predefined Opcode Tags">.
=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>
module.
Each NAME must be the B<name> 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<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...".
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 at sable.ox.ac.uk.
Reworked to use the Opcode module and other changes added by Tim Bunce
E<lt>F<Tim.Bunce at ig.co.uk>E<gt>.
=cut
More information about the dslinux-commit
mailing list