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