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); |
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 | } |
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) |