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