#!perl
# Tests that all ops can be trapped by a Safe compartment
BEGIN {
unless ($ENV{PERL_CORE}) {
# this won't work outside of the core, so exit
print "1..0 # skipped: PERL_CORE unset\n"; exit 0;
}
}
use Config;
BEGIN {
if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
print "1..0\n"; exit 0;
}
# We need test.pl for runperl(). Since this test script is only run in
# the perl core, this should be fine:
require '../../t/test.pl';
}
use strict;
use Safe;
# Read the op names and descriptions directly from opcode.pl
my @op;
my %code;
while (<DATA>) {
chomp;
die "Can't match $_" unless /^([a-z_0-9]+)\t+(.*)/;
$code{$1} = $2;
}
open my $fh, '<', '../../regen/opcodes' or die "Can't open opcodes: $!";
while (<$fh>) {
chomp;
next if !$_ or /^#/;
my ($op, $opname) = split /\t+/;
push @op, [$op, $opname, $code{$op}];
}
close $fh;
plan(tests => scalar @op + 3);
sub testop {
my ($op, $opname, $code) = @_;
pass("$op : skipped") and return if $code =~ /^SKIP/;
pass("$op : skipped") and return if $code =~ m://|~~: && $] < 5.010;
my $c = new Safe;
$c->deny_only($op);
$c->reval($code);
like($@, qr/'\Q$opname\E' trapped by operation mask/, $op);
}
foreach (@op) {
if ($_->[2]) {
testop @$_;
} else {
local our $TODO = "No test yet for $_->[1]";
fail();
}
}
# Test also that the errors resulting from disallowed ops do not cause
# ‘Unbalanced’ warnings.
{
local $ENV{PERL_DESTRUCT_LEVEL}=2;
unlike
runperl(
switches => [ '-MSafe', '-w' ],
prog => 'Safe->new->reval(q(use strict))',
stderr => 1,
),
qr/Unbalanced/,
'No Unbalanced warnings when disallowing ops';
unlike
runperl(
switches => [ '-MSafe', '-w' ],
prog => 'Safe->new->reval(q(use strict), 1)',
stderr => 1,
),
qr/Unbalanced/,
'No Unbalanced warnings when disallowing ops';
unlike
runperl(
switches => [ '-MSafe', '-w' ],
prog => 'Safe->new->reval('
. 'q(BEGIN{$^H{foo}=bar};use strict), 0'
.')',
stderr => 1,
),
qr/Unbalanced/,
'No Unbalanced warnings when disallowing ops with %^H set';
}
# things that begin with SKIP are skipped, for various reasons (notably
# optree modified by the optimizer -- Safe checks are done before the
# optimizer modifies the optree)
__DATA__
null SKIP
stub SKIP
scalar scalar $x
pushmark print @x
wantarray wantarray
const 42
gvsv SKIP (set by optimizer) $x
gv SKIP *x
gelem *x{SCALAR}
padsv SKIP my $x
padav SKIP my @x
padhv SKIP my %x
padany SKIP (not implemented)
pushre SKIP split /foo/
rv2gv *x
rv2sv $x
av2arylen $#x
rv2cv f()
anoncode sub { }
prototype prototype 'foo'
refgen \($x,$y)
srefgen SKIP \$x
ref ref
bless bless
backtick qx/ls/
glob <*.c>
readline <FH>
rcatline SKIP (set by optimizer) $x .= <F>
regcmaybe SKIP (internal)
regcreset SKIP (internal)
regcomp SKIP (internal)
match /foo/
qr qr/foo/
subst s/foo/bar/
substcont SKIP (set by optimizer)
trans y:z:t:
sassign $x = $y
aassign @x = @y
chop chop @foo
schop chop
chomp chomp @foo
schomp chomp
defined defined
undef undef
study study
pos pos
preinc ++$i
i_preinc SKIP (set by optimizer)
predec --$i
i_predec SKIP (set by optimizer)
postinc $i++
i_postinc SKIP (set by optimizer)
postdec $i--
i_postdec SKIP (set by optimizer)
pow $x ** $y
multiply $x * $y
i_multiply SKIP (set by optimizer)
divide $x / $y
i_divide SKIP (set by optimizer)
modulo $x % $y
i_modulo SKIP (set by optimizer)
repeat $x x $y
add $x + $y
i_add SKIP (set by optimizer)
subtract $x - $y
i_subtract SKIP (set by optimizer)
concat $x . $y
stringify "$x"
left_shift $x << 1
right_shift $x >> 1
lt $x < $y
i_lt SKIP (set by optimizer)
gt $x > $y
i_gt SKIP (set by optimizer)
le $i <= $y
i_le SKIP (set by optimizer)
ge $i >= $y
i_ge SKIP (set by optimizer)
eq $x == $y
i_eq SKIP (set by optimizer)
ne $x != $y
i_ne SKIP (set by optimizer)
ncmp $i <=> $y
i_ncmp SKIP (set by optimizer)
slt $x lt $y
sgt $x gt $y
sle $x le $y
sge $x ge $y
seq $x eq $y
sne $x ne $y
scmp $x cmp $y
bit_and $x & $y
bit_xor $x ^ $y
bit_or $x | $y
negate -$x
i_negate SKIP (set by optimizer)
not !$x
complement ~$x
atan2 atan2 1
sin sin 1
cos cos 1
rand rand
srand srand
exp exp 1
log log 1
sqrt sqrt 1
int int
hex hex
oct oct
abs abs
length length
substr substr $x, 1
vec vec
index index
rindex rindex
sprintf sprintf '%s', 'foo'
formline formline
ord ord
chr chr
crypt crypt 'foo','bar'
ucfirst ucfirst
lcfirst lcfirst
uc uc
lc lc
quotemeta quotemeta
rv2av @a
aelemfast SKIP (set by optimizer)
aelem $a[1]
aslice @a[1,2]
each each %h
values values %h
keys keys %h
delete delete $h{Key}
exists exists $h{Key}
rv2hv %h
helem $h{kEy}
hslice @h{kEy}
unpack unpack
pack pack
split split /foo/
join join $a, @b
list @x = (1,2)
lslice SKIP @x[1,2]
anonlist [1,2]
anonhash { a => 1 }
splice splice @x, 1, 2, 3
push push @x, $x
pop pop @x
shift shift @x
unshift unshift @x
sort sort @x
reverse reverse @x
grepstart grep { $_ eq 'foo' } @x
grepwhile SKIP grep { $_ eq 'foo' } @x
mapstart map $_ + 1, @foo
mapwhile SKIP (set by optimizer)
range SKIP
flip 1..2
flop 1..2
and $x && $y
or $x || $y
xor $x xor $y
cond_expr $x ? 1 : 0
andassign $x &&= $y
orassign $x ||= $y
method Foo->$x()
entersub f()
leavesub sub f{} f()
leavesublv sub f:lvalue{return $x} f()
caller caller
warn warn
die die
reset reset
lineseq SKIP
nextstate SKIP
dbstate SKIP (needs debugger)
unstack while(0){}
enter SKIP
leave SKIP
scope SKIP
enteriter SKIP
iter SKIP
enterloop SKIP
leaveloop SKIP
return return
last last
next next
redo redo THIS
dump dump
goto goto THERE
exit exit 0
open open FOO
close close FOO
pipe_op pipe FOO,BAR
fileno fileno FOO
umask umask 0755, 'foo'
binmode binmode FOO
tie tie
untie untie
tied tied
dbmopen dbmopen
dbmclose dbmclose
sselect SKIP (set by optimizer)
select select FOO
getc getc FOO
read read FOO
enterwrite write
leavewrite SKIP
prtf printf
print print
sysopen sysopen
sysseek sysseek
sysread sysread
syswrite syswrite
send send
recv recv
eof eof FOO
tell tell
seek seek FH, $pos, $whence
truncate truncate FOO, 42
fcntl fcntl
ioctl ioctl
flock flock FOO, 1
socket socket
sockpair socketpair
bind bind
connect connect
listen listen
accept accept
shutdown shutdown
gsockopt getsockopt
ssockopt setsockopt
getsockname getsockname
getpeername getpeername
lstat lstat FOO
stat stat FOO
ftrread -R
ftrwrite -W
ftrexec -X
fteread -r
ftewrite -w
fteexec -x
ftis -e
fteowned SKIP -O
ftrowned SKIP -o
ftzero -z
ftsize -s
ftmtime -M
ftatime -A
ftctime -C
ftsock -S
ftchr -c
ftblk -b
ftfile -f
ftdir -d
ftpipe -p
ftlink -l
ftsuid -u
ftsgid -g
ftsvtx -k
fttty -t
fttext -T
ftbinary -B
chdir chdir '/'
chown chown
chroot chroot
unlink unlink 'foo'
chmod chmod 511, 'foo'
utime utime
rename rename 'foo', 'bar'
link link 'foo', 'bar'
symlink symlink 'foo', 'bar'
readlink readlink 'foo'
mkdir mkdir 'foo'
rmdir rmdir 'foo'
open_dir opendir DIR
readdir readdir DIR
telldir telldir DIR
seekdir seekdir DIR, $pos
rewinddir rewinddir DIR
closedir closedir DIR
fork fork
wait wait
waitpid waitpid
system system
exec exec
kill kill
getppid getppid
getpgrp getpgrp
setpgrp setpgrp
getpriority getpriority
setpriority setpriority
time time
tms times
localtime localtime
gmtime gmtime
alarm alarm
sleep sleep 1
shmget shmget
shmctl shmctl
shmread shmread
shmwrite shmwrite
msgget msgget
msgctl msgctl
msgsnd msgsnd
msgrcv msgrcv
semget semget
semctl semctl
semop semop
require use strict
dofile do 'file'
entereval eval "1+1"
leaveeval eval "1+1"
entertry SKIP eval { 1+1 }
leavetry SKIP eval { 1+1 }
ghbyname gethostbyname 'foo'
ghbyaddr gethostbyaddr 'foo'
ghostent gethostent
gnbyname getnetbyname 'foo'
gnbyaddr getnetbyaddr 'foo'
gnetent getnetent
gpbyname getprotobyname 'foo'
gpbynumber getprotobynumber 42
gprotoent getprotoent
gsbyname getservbyname 'name', 'proto'
gsbyport getservbyport 'a', 'b'
gservent getservent
shostent sethostent
snetent setnetent
sprotoent setprotoent
sservent setservent
ehostent endhostent
enetent endnetent
eprotoent endprotoent
eservent endservent
gpwnam getpwnam
gpwuid getpwuid
gpwent getpwent
spwent setpwent
epwent endpwent
ggrnam getgrnam
ggrgid getgrgid
ggrent getgrent
sgrent setgrent
egrent endgrent
getlogin getlogin
syscall syscall
lock SKIP
threadsv SKIP
setstate SKIP
method_named $x->y()
dor $x // $y
dorassign $x //= $y
once SKIP {use feature 'state'; state $foo = 42;}
say SKIP {use feature 'say'; say "foo";}
smartmatch no warnings 'experimental::smartmatch'; $x ~~ $y
aeach SKIP each @t
akeys SKIP keys @t
avalues SKIP values @t
custom SKIP (no way)