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