perl
view release on metacpan or search on metacpan
dist/Devel-PPPort/TODO view on Meta::CPAN
Argv
argvgv
argvoutgv
basetime
beginav
block_type
bodytarget
bufend
bufptr
check
chopset
Cmd
compcv
compiling
comppad
comppad_name
comppad_name_fill
copline
cop_seqmax
cryptseen
cshlen
dist/Devel-PPPort/parts/base/5005000 view on Meta::CPAN
PERLVARIC # Z added by devel/scanprov
Pid_t # K added by devel/scanprov
pipe # Z added by devel/scanprov
PL_amagic_generation # Z added by devel/scanprov
PL_an # Z added by devel/scanprov
PL_argvgv # Z added by devel/scanprov
PL_argvoutgv # Z added by devel/scanprov
PL_basetime # Z added by devel/scanprov
PL_beginav # Z added by devel/scanprov
PL_bodytarget # Z added by devel/scanprov
PL_chopset # Z added by devel/scanprov
PL_collation_ix # Z added by devel/scanprov
PL_collation_name # Z added by devel/scanprov
PL_collation_standard # Z added by devel/scanprov
PL_collxfrm_base # Z added by devel/scanprov
PL_collxfrm_mult # Z added by devel/scanprov
PL_colors # Z added by devel/scanprov
PL_colorset # Z added by devel/scanprov
PL_compcv # Z added by devel/scanprov
PL_compiling # M added by devel/scanprov
PL_comppad_name_fill # Z added by devel/scanprov
dist/Safe/Safe.pm view on Meta::CPAN
if (defined &B::sub_generation) {
*sub_generation = \&B::sub_generation;
}
else {
# fake sub generation changing for perls < 5.8.9
my $sg; *sub_generation = sub { ++$sg };
}
}
use Opcode 1.01, qw(
opset opset_to_ops opmask_add
empty_opset full_opset invert_opset verify_opset
opdesc opcodes opmask define_optag opset_to_hex
);
*ops_to_opset = \&opset; # Temporary alias for old Penguins
# Regular expressions and other unicode-aware code may need to call
# utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the
# SWASHNEW method.
# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
# and sharing makes it look like the method exists.
# The simplest and most robust fix is to ensure the utf8 module is loaded when
# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
require utf8;
dist/Safe/Safe.pm view on Meta::CPAN
return $obj->{Mask} unless @_;
$obj->deny_only(@_);
}
# v1 compatibility methods
sub trap { shift->deny(@_) }
sub untrap { shift->permit(@_) }
sub deny {
my $obj = shift;
$obj->{Mask} |= opset(@_);
}
sub deny_only {
my $obj = shift;
$obj->{Mask} = opset(@_);
}
sub permit {
my $obj = shift;
# XXX needs testing
$obj->{Mask} &= invert_opset opset(@_);
}
sub permit_only {
my $obj = shift;
$obj->{Mask} = invert_opset opset(@_);
}
sub dump_mask {
my $obj = shift;
print opset_to_hex($obj->{Mask}),"\n";
}
sub share {
my($obj, @vars) = @_;
$obj->share_from(scalar(caller), \@vars);
}
sub share_from {
dist/Safe/Safe.pm view on Meta::CPAN
Code evaluated in a compartment compiles subject to the
compartment's operator mask. Attempting to evaluate code in a
compartment which contains a masked operator will cause the
compilation to fail with an error. The code will not be executed.
The default operator mask for a newly created compartment is
the ':default' optag.
It is important that you read the L<Opcode> module documentation
for more information, especially for detailed definitions of opnames,
optags and opsets.
Since it is only at the compilation stage that the operator mask
applies, controlled access to potentially unsafe operations can
be achieved by having a handle to a wrapper subroutine (written
outside the compartment) placed into the compartment. For example,
$cpt = new Safe;
sub wrapper {
# vet arguments and perform potentially unsafe operations
}
dist/Safe/t/safe1.t view on Meta::CPAN
}
}
# Tests Todo:
# 'main' as root
package test; # test from somewhere other than main
our $bar;
use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
opmask_add full_opset empty_opset opcodes opmask define_optag);
use Safe 1.00;
use Test::More;
my $cpt;
# create and destroy some automatic Safe compartments first
$cpt = Safe->new or die;
$cpt = Safe->new or die;
$cpt = Safe->new or die;
dist/Safe/t/safe2.t view on Meta::CPAN
BEGIN {
if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
print "1..0\n";
exit 0;
}
}
# Tests Todo:
# 'main' as root
use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
opmask_add full_opset empty_opset opcodes opmask define_optag);
use Safe 1.00;
use Test::More;
my $TB = Test::Builder->new();
# Set up a package namespace of things to be visible to the unsafe code
$Root::foo = "visible";
our $bar = "invisible";
dist/Safe/t/safe2.t view on Meta::CPAN
push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
is($Root::foo, 'ok 17');
is("@{$cpt->varglob('bar')}", 'ok 18');
use strict;
my $m1 = $cpt->mask;
$cpt->trap("negate");
my $m2 = $cpt->mask;
my @masked = opset_to_ops($m1);
is(opset("negate", @masked), $m2);
is(eval { $cpt->mask("a bad mask") }, undef);
isnt($@, '');
is($cpt->reval("2 + 2"), 4);
my $test = $TB->current_test() + 1;
$cpt->reval("
my \$todo = \$] < 5.021007 ? ' # TODO' : '';
print defined wantarray
dist/Safe/t/safeutf8.t view on Meta::CPAN
#!perl -w
use Config;
use Test::More
$Config{'extensions'} =~ /\bOpcode\b/ || $Config{'osname'} eq 'VMS'
? (tests => 7)
: (skip_all => "no Opcode extension and we're not on VMS");
use Safe 1.00;
use Opcode qw(full_opset);
$| = 1;
pass;
my $safe = Safe->new('PLPerl');
$safe->deny_only();
# Expression that triggers require utf8 and call to SWASHNEW.
# Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called"
# if SWASHNEW is not shared, else returns true if unicode logic is working.
# define PL_beginav (vTHX->Ibeginav)
# define PL_beginav_save (vTHX->Ibeginav_save)
# define PL_blockhooks (vTHX->Iblockhooks)
# define PL_body_arenas (vTHX->Ibody_arenas)
# define PL_body_roots (vTHX->Ibody_roots)
# define PL_bodytarget (vTHX->Ibodytarget)
# define PL_breakable_sub_gen (vTHX->Ibreakable_sub_gen)
# define PL_CCC_non0_non230 (vTHX->ICCC_non0_non230)
# define PL_checkav (vTHX->Icheckav)
# define PL_checkav_save (vTHX->Icheckav_save)
# define PL_chopset (vTHX->Ichopset)
# define PL_clocktick (vTHX->Iclocktick)
# define PL_collation_ix (vTHX->Icollation_ix)
# define PL_collation_name (vTHX->Icollation_name)
# define PL_collation_standard (vTHX->Icollation_standard)
# define PL_collxfrm_base (vTHX->Icollxfrm_base)
# define PL_collxfrm_mult (vTHX->Icollxfrm_mult)
# define PL_colors (vTHX->Icolors)
# define PL_colorset (vTHX->Icolorset)
# define PL_compcv (vTHX->Icompcv)
# define PL_compiling (vTHX->Icompiling)
ext/Opcode/Opcode.pm view on Meta::CPAN
package Opcode 1.69;
use strict;
use Carp;
use Exporter 'import';
use XSLoader;
sub opset (;@);
sub opset_to_hex ($);
sub opdump (;$);
use subs our @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
);
XSLoader::load();
_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/(?:\t|--).*// } # 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__
ext/Opcode/Opcode.pm view on Meta::CPAN
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
ext/Opcode/Opcode.pm view on Meta::CPAN
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
equivalent
$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
ext/Opcode/Opcode.xs view on Meta::CPAN
#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 */
#ifdef OPCODE_DEBUG
int x_opcode_debug; /* unused warn() emitting debugging code */
#endif
} my_cxt_t;
START_MY_CXT
/* length of opmasks in bytes */
static const STRLEN opset_len = (PL_maxo + 7) / 8;
#define op_named_bits (MY_CXT.x_op_named_bits)
#define opset_all (MY_CXT.x_opset_all)
#ifdef OPCODE_DEBUG
# define opcode_debug (MY_CXT.x_opcode_debug)
#else
/* no API to turn this on at runtime, so constant fold the code away */
# define opcode_debug 0
#endif
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
*/
ext/Opcode/Opcode.xs view on Meta::CPAN
op_named_bits = newHV();
hv_ksplit(op_named_bits, PL_maxo);
op_names = PL_op_name;
for(i=0; i < PL_maxo; ++i) {
SV * const sv = newSViv(i);
SvREADONLY_on(sv);
(void) hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
}
put_op_bitspec(aTHX_ STR_WITH_LEN(":none"), sv_2mortal(new_opset(aTHX_ Nullsv)));
opset_all = new_opset(aTHX_ Nullsv);
bitmap = (U8*)SvPV(opset_all, len);
memset(bitmap, 0xFF, len-1); /* deal with last byte specially, see below */
/* Take care to set the right number of bits in the last byte */
bitmap[len-1] = (PL_maxo & 0x07) ? ((U8) (~(0xFF << (PL_maxo & 0x07))))
: 0xFF;
put_op_bitspec(aTHX_ STR_WITH_LEN(":all"), 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);
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).
ext/Opcode/Opcode.xs view on Meta::CPAN
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(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 = NULL;
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, const char *opname)
{
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) == 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 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 (STRLEN 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;
#ifdef OPCODE_DEBUG
dMY_CXT;
#endif
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_nocontext,
"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;
STATIC_ASSERT_STMT(PL_maxo < OP_MASK_BUF_SIZE);
if (opcode_debug >= 1)
warn("opset_len %ld\n", (long)opset_len);
op_names_init(aTHX);
}
void
_safe_pkg_prep(Package)
SV *Package
PPCODE:
HV *hv;
char *hvname;
ENTER;
ext/Opcode/Opcode.xs view on Meta::CPAN
sv_free( (SV *) dummy_hv); /* get rid of what save_hash gave us*/
SPAGAIN; /* for the PUTBACK added by xsubpp */
LEAVE;
/* Invalidate again */
++PL_sub_generation;
hv_clear(PL_stashcache);
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] &= ~(char)(0xFF << (PL_maxo & 0x07));
}
ST(0) = opset;
void
opset_to_ops(opset, desc = 0)
SV *opset
int desc
PPCODE:
{
STRLEN len;
STRLEN i;
int j, myopcode;
const char * const bitmap = SvPV(opset, len);
const char *const *names = (desc) ? PL_op_desc : PL_op_name;
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(newSVpvn_flags(names[myopcode], strlen(names[myopcode]),
SVs_TEMP));
}
}
}
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
ext/Opcode/Opcode.xs view on Meta::CPAN
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_fetchs((HV*)SvRV(safe), "Mask", 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;
ext/Opcode/Opcode.xs view on Meta::CPAN
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(newSVpvn_flags(op_desc[myopcode], strlen(op_desc[myopcode]),
SVs_TEMP));
}
else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
STRLEN b;
int 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(newSVpvn_flags(op_desc[myopcode],
strlen(op_desc[myopcode]),
SVs_TEMP));
}
}
else
croak("panic: invalid bitspec for \"%s\" (type %u)",
ext/Opcode/Opcode.xs view on Meta::CPAN
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_V == G_LIST) {
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);
}
}
ext/Opcode/ops.pm view on Meta::CPAN
package ops;
our $VERSION = '1.02';
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
ext/Opcode/t/Opcode.t view on Meta::CPAN
{
my @warnings;
BEGIN {
local $SIG{__WARN__} = sub {
push @warnings, "@_";
};
use_ok('Opcode', qw(
opcodes opdesc opmask verify_opset
opset opset_to_ops opset_to_hex invert_opset
opmask_add full_opset empty_opset define_optag
));
}
is_deeply(\@warnings, [], "No warnings loading Opcode");
}
# --- opset_to_ops and opset
my @empty_l = opset_to_ops(empty_opset);
is_deeply (\@empty_l, []);
my @full_l1 = opset_to_ops(full_opset);
is (scalar @full_l1, scalar opcodes());
{
local $::TODO = "opcodes in list context not yet implemented";
my @full_l2 = eval {opcodes()};
is($@, '');
is_deeply(\@full_l1, \@full_l2);
}
@empty_l = opset_to_ops(opset(':none'));
is_deeply(\@empty_l, []);
my @full_l3 = opset_to_ops(opset(':all'));
is_deeply(\@full_l1, \@full_l3);
my $s1 = opset( 'padsv');
my $s2 = opset($s1, 'padav');
my $s3 = opset($s2, '!padav');
isnt($s1, $s2);
is($s1, $s3);
# --- define_optag
is(eval { opset(':_tst_') }, undef);
like($@, qr/Unknown operator tag ":_tst_"/);
define_optag(":_tst_", opset(qw(padsv padav padhv)));
isnt(eval { opset(':_tst_') }, undef);
is($@, '');
# --- opdesc and opcodes
is(opdesc("gv"), "glob value");
my @desc = opdesc(':_tst_','stub');
is_deeply(\@desc, ['private variable', 'private array', 'private hash', 'stub']);
isnt(opcodes(), 0);
# --- invert_opset
$s1 = opset(qw(fileno padsv padav));
my @o1 = opset_to_ops(invert_opset($s1));
is(scalar @o1, opcodes-3);
# --- opmask
is(opmask(), empty_opset());
is(length opmask(), int((opcodes()+7)/8));
# --- verify_opset
is(verify_opset($s1), 1);
is(verify_opset(42), 0);
# --- opmask_add
opmask_add(opset(qw(fileno))); # add to global op_mask
is(eval 'fileno STDOUT', undef);
like($@, qr/'fileno' trapped/);
# --- check use of bit vector ops on opsets
$s1 = opset('padsv');
$s2 = opset('padav');
$s3 = opset('padsv', 'padav', 'padhv');
# Non-negated
is(($s1 | $s2), opset($s1,$s2));
is(($s2 & $s3), opset($s2));
is(($s2 ^ $s3), opset('padsv','padhv'));
# Negated, e.g., with possible extra bits in last byte beyond last op bit.
# The extra bits mean we can't just say ~mask eq invert_opset(mask).
@o1 = opset_to_ops( ~ $s3);
my @o2 = opset_to_ops(invert_opset $s3);
is_deeply(\@o1, \@o2);
# --- test context of undocumented _safe_call_sv (used by Safe.pm)
my %inc = %INC;
my $expect;
sub f {
%INC = %inc;
no warnings 'uninitialized';
is wantarray, $expect,
sprintf "_safe_call_sv gives %s context",
qw[void scalar list][$expect + defined $expect]
};
Opcode::_safe_call_sv("main", empty_opset, \&f);
$expect = !1;
$_ = Opcode::_safe_call_sv("main", empty_opset, \&f);
$expect = !0;
() = Opcode::_safe_call_sv("main", empty_opset, \&f);
# --- finally, check some opname assertions
foreach my $opname (@full_l1) {
unlike($opname, qr/\W/, "opname $opname has no non-'word' characters");
unlike($opname, qr/^\d/, "opname $opname does not start with a digit");
}
done_testing();
case '9': /* $9 */
paren = *name - '0';
storeparen:
/* Flag the capture variables with a NULL mg_ptr
Use mg_len for the array index to lookup. */
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
break;
case ':': /* $: */
sv_setpv(GvSVn(gv),PL_chopset);
goto magicalize;
case '?': /* $? */
#ifdef COMPLEX_STATUS
SvUPGRADE(GvSVn(gv), SVt_PVLV);
#endif
goto magicalize;
case '!': /* $! */
GvMULTI_on(gv);
each initialized at creation time with the current value of the creating
thread's copy.
=cut
*/
PERLVAR(I, rs, SV *) /* input record separator $/ */
PERLVAR(I, last_in_gv, GV *) /* GV used in last <FH> */
PERLVAR(I, ofsgv, GV *) /* GV of output field separator *, */
PERLVAR(I, defoutgv, GV *) /* default FH for output */
PERLVARI(I, chopset, const char *, " \n-") /* $: */
PERLVAR(I, formtarget, SV *)
PERLVAR(I, bodytarget, SV *)
PERLVAR(I, toptarget, SV *)
PERLVAR(I, restartop, OP *) /* propagating an error from croak? */
PERLVAR(I, restartjmpenv, JMPENV *) /* target frame for longjmp in die */
PERLVAR(I, top_env, JMPENV *) /* ptr to current sigjmp environment */
PERLVAR(I, start_env, JMPENV) /* empty startup sigjmp environment */
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
else {
croak("setegid() not implemented");
}
#endif
break;
}
case ':':
PL_chopset = SvPV_force(sv,len);
break;
case '$': /* $$ */
/* Store the pid in mg->mg_obj so we can tell when a fork has
occurred. mg->mg_obj points to *$ by default, so clear it. */
if (isGV(mg->mg_obj)) {
if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
SvREFCNT_dec(mg->mg_obj);
mg->mg_flags |= MGf_REFCOUNTED;
mg->mg_obj = newSViv((IV)PerlProc_getpid());
}
U32 *fpc; /* format ops program counter */
char *t; /* current append position in target string */
const char *f; /* current position in format string */
I32 arg;
SV *sv = NULL; /* current item */
const char *item = NULL;/* string value of current item */
I32 itemsize = 0; /* length (chars) of item, possibly truncated */
I32 itembytes = 0; /* as itemsize, but length in bytes */
I32 fieldsize = 0; /* width of current field */
I32 lines = 0; /* number of lines that have been output */
bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
const char *chophere = NULL; /* where to chop current item */
STRLEN linemark = 0; /* pos of start of line in output */
NV value;
bool gotsome = FALSE; /* seen at least one non-blank item on this line */
STRLEN len; /* length of current sv */
STRLEN linemax; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
const char *fmt;
MAGIC *mg = NULL;
* following the last field char; so if fieldsize=3
* and item="a b cdef", we consume "a b", not "a".
* Ditto further down.
*/
if (size == fieldsize)
break;
}
else {
if (size == fieldsize)
break;
if (strchr(PL_chopset, *s)) {
/* provisional split point */
/* for a non-space split char, we include
* the split char; hence the '+1' */
chophere = s + 1;
itemsize = size + 1;
}
if (!isCNTRL(*s))
gotsome = TRUE;
}
PL_statcache = proto_perl->Istatcache;
#ifndef NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
#else
PL_tainted = FALSE;
#endif
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_restartjmpenv = proto_perl->Irestartjmpenv;
PL_restartop = proto_perl->Irestartop;
PL_in_eval = proto_perl->Iin_eval;
PL_delaymagic = proto_perl->Idelaymagic;
PL_phase = proto_perl->Iphase;
PL_localizing = proto_perl->Ilocalizing;
PL_hv_fetch_ent_mh = NULL;
PL_modcount = proto_perl->Imodcount;
( run in 1.285 second using v1.01-cache-2.11-cpan-71847e10f99 )