[p5sagit/p5-mst-13.2.git] / dist / Safe / t / safeops.t

#!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;
    }
}

use strict;
use Test::More;
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, '<', '../../opcode.pl' or die "Can't open opcode.pl: $!";
while (<$fh>) {
    last if /^__END__/;
}
while (<$fh>) {
    chomp;
    next if !$_ or /^#/;
    my ($op, $opname) = split /\t+/;
    push @op, [$op, $opname, $code{$op}];
}
close $fh;

plan(tests => scalar @op);

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 $TODO = "No test yet for $_->[1]";
	fail();
    }
}

# 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	$x ~~ $y
aeach		SKIP each @t
akeys		SKIP keys @t
avalues		SKIP values @t
custom		SKIP (no way)
Commit	Line	Data
6c52f3eb	1	#!perl
	2	# Tests that all ops can be trapped by a Safe compartment
	3
	4	BEGIN {
c81476ca	5	unless ($ENV{PERL_CORE}) {
6c52f3eb	6	# this won't work outside of the core, so exit
54f12473	7	print "1..0 # skipped: PERL_CORE unset\n"; exit 0;
6c52f3eb	8	}
	9	}
	10	use Config;
	11	BEGIN {
	12	if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
	13	print "1..0\n"; exit 0;
	14	}
	15	}
	16
	17	use strict;
78396813	18	use Test::More;
6c52f3eb	19	use Safe;
	20
	21	# Read the op names and descriptions directly from opcode.pl
	22	my @op;
78396813	23	my %code;
	24
	25	while (<DATA>) {
	26	chomp;
	27	die "Can't match $_" unless /^([a-z_0-9]+)\t+(.*)/;
	28	$code{$1} = $2;
	29	}
	30
c81476ca	31	open my $fh, '<', '../../opcode.pl' or die "Can't open opcode.pl: $!";
6c52f3eb	32	while (<$fh>) {
	33	last if /^__END__/;
	34	}
	35	while (<$fh>) {
	36	chomp;
	37	next if !$_ or /^#/;
	38	my ($op, $opname) = split /\t+/;
78396813	39	push @op, [$op, $opname, $code{$op}];
6c52f3eb	40	}
	41	close $fh;
	42
78396813	43	plan(tests => scalar @op);
78396813	44
6c52f3eb	45	sub testop {
	46	my ($op, $opname, $code) = @_;
	47	pass("$op : skipped") and return if $code =~ /^SKIP/;
4bc6199f	48	pass("$op : skipped") and return if $code =~ m://\|~~: && $] < 5.010;
6c52f3eb	49	my $c = new Safe;
	50	$c->deny_only($op);
	51	$c->reval($code);
	52	like($@, qr/'\Q$opname\E' trapped by operation mask/, $op);
	53	}
	54
78396813	55	foreach (@op) {
	56	if ($_->[2]) {
	57	testop @$_;
	58	} else {
	59	local $TODO = "No test yet for $_->[1]";
	60	fail();
	61	}
6c52f3eb	62	}
6c52f3eb	63
6c52f3eb	64	# things that begin with SKIP are skipped, for various reasons (notably
	65	# optree modified by the optimizer -- Safe checks are done before the
	66	# optimizer modifies the optree)
	67
	68	__DATA__
78396813	69	null SKIP
	70	stub SKIP
	71	scalar scalar $x
	72	pushmark print @x
	73	wantarray wantarray
	74	const 42
	75	gvsv SKIP (set by optimizer) $x
	76	gv SKIP *x
	77	gelem *x{SCALAR}
	78	padsv SKIP my $x
	79	padav SKIP my @x
	80	padhv SKIP my %x
	81	padany SKIP (not implemented)
	82	pushre SKIP split /foo/
	83	rv2gv *x
	84	rv2sv $x
	85	av2arylen $#x
	86	rv2cv f()
	87	anoncode sub { }
	88	prototype prototype 'foo'
	89	refgen \($x,$y)
	90	srefgen SKIP \$x
	91	ref ref
	92	bless bless
	93	backtick qx/ls/
	94	glob <*.c>
	95	readline <FH>
	96	rcatline SKIP (set by optimizer) $x .= <F>
	97	regcmaybe SKIP (internal)
	98	regcreset SKIP (internal)
	99	regcomp SKIP (internal)
	100	match /foo/
	101	qr qr/foo/
	102	subst s/foo/bar/
	103	substcont SKIP (set by optimizer)
	104	trans y:z:t:
	105	sassign $x = $y
	106	aassign @x = @y
	107	chop chop @foo
	108	schop chop
	109	chomp chomp @foo
	110	schomp chomp
	111	defined defined
	112	undef undef
	113	study study
	114	pos pos
	115	preinc ++$i
	116	i_preinc SKIP (set by optimizer)
	117	predec --$i
	118	i_predec SKIP (set by optimizer)
	119	postinc $i++
	120	i_postinc SKIP (set by optimizer)
	121	postdec $i--
	122	i_postdec SKIP (set by optimizer)
	123	pow $x ** $y
	124	multiply $x * $y
	125	i_multiply SKIP (set by optimizer)
	126	divide $x / $y
	127	i_divide SKIP (set by optimizer)
	128	modulo $x % $y
	129	i_modulo SKIP (set by optimizer)
	130	repeat $x x $y
	131	add $x + $y
	132	i_add SKIP (set by optimizer)
133	subtract $x - $y
134	i_subtract SKIP (set by optimizer)
135	concat $x . $y
136	stringify "$x"
137	left_shift $x << 1
138	right_shift $x >> 1
139	lt $x < $y
140	i_lt SKIP (set by optimizer)
141	gt $x > $y
142	i_gt SKIP (set by optimizer)
143	le $i <= $y
144	i_le SKIP (set by optimizer)
145	ge $i >= $y
146	i_ge SKIP (set by optimizer)
147	eq $x == $y
148	i_eq SKIP (set by optimizer)
149	ne $x != $y
150	i_ne SKIP (set by optimizer)
151	ncmp $i <=> $y
152	i_ncmp SKIP (set by optimizer)
153	slt $x lt $y
154	sgt $x gt $y
155	sle $x le $y
156	sge $x ge $y
157	seq $x eq $y
158	sne $x ne $y
159	scmp $x cmp $y
160	bit_and $x & $y
161	bit_xor $x ^ $y
162	bit_or $x \| $y
163	negate -$x
164	i_negate SKIP (set by optimizer)
165	not !$x
166	complement ~$x
167	atan2 atan2 1
168	sin sin 1
169	cos cos 1
170	rand rand
171	srand srand
172	exp exp 1
173	log log 1
174	sqrt sqrt 1
175	int int
176	hex hex
177	oct oct
178	abs abs
179	length length
180	substr substr $x, 1
181	vec vec
182	index index
183	rindex rindex
184	sprintf sprintf '%s', 'foo'
185	formline formline
186	ord ord
187	chr chr
188	crypt crypt 'foo','bar'
189	ucfirst ucfirst
190	lcfirst lcfirst
191	uc uc
192	lc lc
193	quotemeta quotemeta
194	rv2av @a
195	aelemfast SKIP (set by optimizer)
196	aelem $a[1]
197	aslice @a[1,2]
198	each each %h
199	values values %h
200	keys keys %h
201	delete delete $h{Key}
202	exists exists $h{Key}
203	rv2hv %h
204	helem $h{kEy}
205	hslice @h{kEy}
206	unpack unpack
207	pack pack
208	split split /foo/
209	join join $a, @b
210	list @x = (1,2)
211	lslice SKIP @x[1,2]
212	anonlist [1,2]
213	anonhash { a => 1 }
214	splice splice @x, 1, 2, 3
215	push push @x, $x
216	pop pop @x
217	shift shift @x
218	unshift unshift @x
219	sort sort @x
220	reverse reverse @x
221	grepstart grep { $_ eq 'foo' } @x
222	grepwhile SKIP grep { $_ eq 'foo' } @x
223	mapstart map $_ + 1, @foo
224	mapwhile SKIP (set by optimizer)
225	range SKIP
226	flip 1..2
227	flop 1..2
228	and $x && $y
229	or $x \|\| $y
230	xor $x xor $y
231	cond_expr $x ? 1 : 0
232	andassign $x &&= $y
233	orassign $x \|\|= $y
234	method Foo->$x()
235	entersub f()
236	leavesub sub f{} f()
237	leavesublv sub f:lvalue{return $x} f()
238	caller caller
239	warn warn
240	die die
241	reset reset
242	lineseq SKIP
243	nextstate SKIP
244	dbstate SKIP (needs debugger)
245	unstack while(0){}
246	enter SKIP
247	leave SKIP
248	scope SKIP
249	enteriter SKIP
250	iter SKIP
251	enterloop SKIP
252	leaveloop SKIP
253	return return
254	last last
255	next next
256	redo redo THIS
257	dump dump
258	goto goto THERE
259	exit exit 0
260	open open FOO
261	close close FOO
262	pipe_op pipe FOO,BAR
263	fileno fileno FOO
264	umask umask 0755, 'foo'
265	binmode binmode FOO
266	tie tie
267	untie untie
268	tied tied
269	dbmopen dbmopen
270	dbmclose dbmclose
271	sselect SKIP (set by optimizer)
272	select select FOO
273	getc getc FOO
274	read read FOO
275	enterwrite write
276	leavewrite SKIP
277	prtf printf
278	print print
279	sysopen sysopen
280	sysseek sysseek
281	sysread sysread
282	syswrite syswrite
283	send send
284	recv recv
285	eof eof FOO
286	tell tell
287	seek seek FH, $pos, $whence
288	truncate truncate FOO, 42
289	fcntl fcntl
290	ioctl ioctl
291	flock flock FOO, 1
292	socket socket
293	sockpair socketpair
294	bind bind
295	connect connect
296	listen listen
297	accept accept
298	shutdown shutdown
299	gsockopt getsockopt
300	ssockopt setsockopt
301	getsockname getsockname
302	getpeername getpeername
303	lstat lstat FOO
304	stat stat FOO
305	ftrread -R
306	ftrwrite -W
307	ftrexec -X
308	fteread -r
309	ftewrite -w
310	fteexec -x
311	ftis -e
312	fteowned SKIP -O
313	ftrowned SKIP -o
314	ftzero -z
315	ftsize -s
316	ftmtime -M
317	ftatime -A
318	ftctime -C
319	ftsock -S
320	ftchr -c
321	ftblk -b
322	ftfile -f
323	ftdir -d
324	ftpipe -p
325	ftlink -l
326	ftsuid -u
327	ftsgid -g
328	ftsvtx -k
329	fttty -t
330	fttext -T
331	ftbinary -B
332	chdir chdir '/'
333	chown chown
334	chroot chroot
335	unlink unlink 'foo'
336	chmod chmod 511, 'foo'
337	utime utime
338	rename rename 'foo', 'bar'
339	link link 'foo', 'bar'
340	symlink symlink 'foo', 'bar'
341	readlink readlink 'foo'
342	mkdir mkdir 'foo'
343	rmdir rmdir 'foo'
344	open_dir opendir DIR
345	readdir readdir DIR
346	telldir telldir DIR
347	seekdir seekdir DIR, $pos
348	rewinddir rewinddir DIR
349	closedir closedir DIR
350	fork fork
351	wait wait
352	waitpid waitpid
353	system system
354	exec exec
355	kill kill
356	getppid getppid
357	getpgrp getpgrp
358	setpgrp setpgrp
359	getpriority getpriority
360	setpriority setpriority
361	time time
362	tms times
363	localtime localtime
364	gmtime gmtime
365	alarm alarm
366	sleep sleep 1
367	shmget shmget
368	shmctl shmctl
369	shmread shmread
370	shmwrite shmwrite
371	msgget msgget
372	msgctl msgctl
373	msgsnd msgsnd
374	msgrcv msgrcv
375	semget semget
376	semctl semctl
377	semop semop
378	require use strict
379	dofile do 'file'
380	entereval eval "1+1"
381	leaveeval eval "1+1"
382	entertry SKIP eval { 1+1 }
383	leavetry SKIP eval { 1+1 }
384	ghbyname gethostbyname 'foo'
385	ghbyaddr gethostbyaddr 'foo'
386	ghostent gethostent
387	gnbyname getnetbyname 'foo'
388	gnbyaddr getnetbyaddr 'foo'
389	gnetent getnetent
390	gpbyname getprotobyname 'foo'
391	gpbynumber getprotobynumber 42
392	gprotoent getprotoent
393	gsbyname getservbyname 'name', 'proto'
394	gsbyport getservbyport 'a', 'b'
395	gservent getservent
396	shostent sethostent
397	snetent setnetent
398	sprotoent setprotoent
399	sservent setservent
400	ehostent endhostent
401	enetent endnetent
402	eprotoent endprotoent
403	eservent endservent
404	gpwnam getpwnam
405	gpwuid getpwuid
406	gpwent getpwent
407	spwent setpwent
408	epwent endpwent
409	ggrnam getgrnam
410	ggrgid getgrgid
411	ggrent getgrent
412	sgrent setgrent
413	egrent endgrent
414	getlogin getlogin
415	syscall syscall
416	lock SKIP
417	threadsv SKIP
418	setstate SKIP
419	method_named $x->y()
420	dor $x // $y
421	dorassign $x //= $y
4bc6199f	422	once SKIP {use feature 'state'; state $foo = 42;}
	423	say SKIP {use feature 'say'; say "foo";}
	424	smartmatch $x ~~ $y
	425	aeach SKIP each @t
	426	akeys SKIP keys @t
	427	avalues SKIP values @t
78396813	428	custom SKIP (no way)