1#!perl 2# Tests that all ops can be trapped by a Safe compartment 3 4BEGIN { 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} 10use Config; 11BEGIN { 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 21use strict; 22use Safe; 23 24# Read the op names and descriptions directly from opcode.pl 25my @op; 26my %code; 27 28while (<DATA>) { 29 chomp; 30 die "Can't match $_" unless /^([a-z_0-9]+)\t+(.*)/; 31 $code{$1} = $2; 32} 33 34open my $fh, '<', '../../regen/opcodes' or die "Can't open opcodes: $!"; 35while (<$fh>) { 36 chomp; 37 next if !$_ or /^#/; 38 my ($op, $opname) = split /\t+/; 39 push @op, [$op, $opname, $code{$op}]; 40} 41close $fh; 42 43plan(tests => scalar @op + 3); 44 45sub 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 55foreach (@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__ 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 454once SKIP {use feature 'state'; state $foo = 42;} 455say SKIP {use feature 'say'; say "foo";} 456smartmatch no warnings 'experimental::smartmatch'; $x ~~ $y 457aeach SKIP each @t 458akeys SKIP keys @t 459avalues SKIP values @t 460custom SKIP (no way) 461