Add a new regression test for Safe : tests that all ops

can be trapped by a Safe compartement (except for the ones
that can't.)

p4raw-id: //depot/perl@20623

2 files changed, 416 insertions, 0 deletions

diff --git a/MANIFEST b/MANIFEST
index 0fc45825e5..35c3d67ccb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -601,6 +601,7 @@ ext/re/t/re.t			see if re pragma works
 ext/Safe/t/safe1.t		See if Safe works
 ext/Safe/t/safe2.t		See if Safe works
 ext/Safe/t/safe3.t		See if Safe works
+ext/Safe/t/safeops.t		Tests that all ops can be trapped by Safe
 ext/SDBM_File/Makefile.PL	SDBM extension makefile writer
 ext/SDBM_File/sdbm/biblio	SDBM kit
 ext/SDBM_File/sdbm/CHANGES	SDBM kit
diff --git a/ext/Safe/t/safeops.t b/ext/Safe/t/safeops.t
new file mode 100644
index 0000000000..285e97814d
--- /dev/null
+++ b/ext/Safe/t/safeops.t
@@ -0,0 +1,415 @@
+#!perl
+# Tests that all ops can be trapped by a Safe compartment
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+    }
+    else {
+	# this won't work outside of the core, so exit
+        print "1..0\n"; exit 0;
+    }
+}
+use Config;
+BEGIN {
+    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+        print "1..0\n"; exit 0;
+    }
+}
+
+use strict;
+use Test::More tests => 354;
+use Safe;
+
+# Read the op names and descriptions directly from opcode.pl
+my @op;
+my @opname;
+open my $fh, '<', '../opcode.pl' or die "Can't open opcode.pl: $!";
+while (<$fh>) {
+    last if /^__END__/;
+}
+while (<$fh>) {
+    chomp;
+    next if !$_ or /^#/;
+    my ($op, $opname) = split /\t+/;
+    push @op, $op;
+    push @opname, $opname;
+}
+close $fh;
+
+sub testop {
+    my ($op, $opname, $code) = @_;
+    pass("$op : skipped") and return if $code =~ /^SKIP/;
+    my $c = new Safe;
+    $c->deny_only($op);
+    $c->reval($code);
+    like($@, qr/'\Q$opname\E' trapped by operation mask/, $op);
+}
+
+my $i = 0;
+while (<DATA>) {
+    testop $op[$i], $opname[$i], $_;
+    ++$i;
+}
+
+# lists op examples, in the same order than opcode.pl
+# things that begin with SKIP are skipped, for various reasons (notably
+# optree modified by the optimizer -- Safe checks are done before the
+# optimizer modifies the optree)
+
+__DATA__
+SKIP # null
+SKIP # stub
+scalar $x # scalar
+print @x # pushmark
+wantarray # wantarray
+42 # const
+SKIP (set by optimizer) $x # gvsv
+SKIP *x # gv
+*x{SCALAR} # gelem
+SKIP my $x # padsv
+SKIP my @x # padav
+SKIP my %x # padhv
+SKIP (not implemented) # padany
+SKIP split /foo/ # pushre
+*x # rv2gv
+$x # rv2sv
+$#x # av2arylen
+f() # rv2cv
+sub { } # anoncode
+prototype 'foo' # prototype
+\($x,$y) # refgen
+SKIP \$x # srefgen
+ref # ref
+bless # bless
+qx/ls/ # backtick
+<*.c> # glob
+<FH> # readline
+SKIP (set by optimizer) $x .= <F> # rcatline
+SKIP (internal) # regcmaybe
+SKIP (internal) # regcreset
+SKIP (internal) # regcomp
+/foo/ # match
+qr/foo/ # qr
+s/foo/bar/ # subst
+SKIP (set by optimizer) # substcont
+y:z:t: # trans
+$x = $y # sassign
+@x = @y # aassign
+chop @foo # chop
+chop # schop
+chomp @foo # chomp
+chomp # schomp
+defined # defined
+undef # undef
+study # study
+pos # pos
+++$i # preinc
+SKIP (set by optimizer) # i_preinc
+--$i # predec
+SKIP (set by optimizer) # i_predec
+$i++ # postinc
+SKIP (set by optimizer) # i_postinc
+$i-- # postdec
+SKIP (set by optimizer) # i_postdec
+$x ** $y # pow
+$x * $y # multiply
+SKIP (set by optimizer) # i_multiply
+$x / $y # divide
+SKIP (set by optimizer) # i_divide
+$x % $y # modulo
+SKIP (set by optimizer) # i_modulo
+$x x $y # repeat
+$x + $y # add
+SKIP (set by optimizer) # i_add
+$x - $y # subtract
+SKIP (set by optimizer) # i_subtract
+$x . $y # concat
+"$x" # stringify
+$x << 1 # left_shift
+$x >> 1 # right_shift
+$x < $y # lt
+SKIP (set by optimizer) # i_lt
+$x > $y # gt
+SKIP (set by optimizer) # i_gt
+$i <= $y # le
+SKIP (set by optimizer) # i_le
+$i >= $y # ge
+SKIP (set by optimizer) # i_ge
+$x == $y # eq
+SKIP (set by optimizer) # i_eq
+$x != $y # ne
+SKIP (set by optimizer) # i_ne
+$i <=> $y # ncmp
+SKIP (set by optimizer) # i_ncmp
+$x lt $y # slt
+$x gt $y # sgt
+$x le $y # sle
+$x ge $y # sge
+$x eq $y # seq
+$x ne $y # sne
+$x cmp $y # scmp
+$x & $y # bit_and
+$x ^ $y # bit_xor
+$x | $y # bit_or
+-$x # negate
+SKIP (set by optimizer) # i_negate
+!$x # not
+~$x # complement
+atan2 1 # atan2
+sin 1 # sin
+cos 1 # cos
+rand # rand
+srand # srand
+exp 1 # exp
+log 1 # log
+sqrt 1 # sqrt
+int # int
+hex # hex
+oct # oct
+abs # abs
+length # length
+substr $x, 1 # substr
+vec # vec
+index # index
+rindex # rindex
+sprintf '%s', 'foo' # sprintf
+formline # formline
+ord # ord
+chr # chr
+crypt 'foo','bar' # crypt
+ucfirst # ucfirst
+lcfirst # lcfirst
+uc # uc
+lc # lc
+quotemeta # quotemeta
+@a # rv2av
+SKIP (set by optimizer) # aelemfast
+$a[1] # aelem
+@a[1,2] # aslice
+each %h # each
+values %h # values
+keys %h # keys
+delete $h{Key} # delete
+exists $h{Key} # exists
+%h # rv2hv
+$h{kEy} # helem
+@h{kEy} # hslice
+unpack # unpack
+pack # pack
+split /foo/ # split
+join $a, @b # join
+@x = (1,2) # list
+SKIP @x[1,2] # lslice
+[1,2] # anonlist
+{ a => 1 } # anonhash
+splice @x, 1, 2, 3 # splice
+push @x, $x # push
+pop @x # pop
+shift @x # shift
+unshift @x # unshift
+sort @x # sort
+reverse @x # reverse
+grep { $_ eq 'foo' } @x # grepstart
+SKIP grep { $_ eq 'foo' } @x # grepwhile
+map $_ + 1, @foo # mapstart
+SKIP (set by optimizer) # mapwhile
+SKIP # range
+1..2 # flip
+1..2 # flop
+$x && $y # and
+$x || $y # or
+$x xor $y # xor
+$x ? 1 : 0 # cond_expr
+$x &&= $y # andassign
+$x ||= $y # orassign
+Foo->$x() # method
+f() # entersub
+sub f{} f() # leavesub
+sub f:lvalue{return $x} f() # leavesublv
+caller # caller
+warn # warn
+die # die
+reset # reset
+SKIP # lineseq
+SKIP # nextstate
+SKIP (needs debugger) # dbstate
+while(0){} # unstack
+SKIP # enter
+SKIP # leave
+SKIP # scope
+SKIP # enteriter
+SKIP # iter
+SKIP # enterloop
+SKIP # leaveloop
+return # return
+last # last
+next # next
+redo THIS # redo
+dump # dump
+goto THERE # goto
+exit 0 # exit
+open FOO # open
+close FOO # close
+pipe FOO,BAR # pipe_op
+fileno FOO # fileno
+umask 0755, 'foo' # umask
+binmode FOO # binmode
+tie # tie
+untie # untie
+tied # tied
+dbmopen # dbmopen
+dbmclose # dbmclose
+SKIP (set by optimizer) # sselect
+select FOO # select
+getc FOO # getc
+read FOO # read
+write # enterwrite
+SKIP # leavewrite
+printf # prtf
+print # print
+sysopen # sysopen
+sysseek # sysseek
+sysread # sysread
+syswrite # syswrite
+send # send
+recv # recv
+eof FOO # eof
+tell # tell
+seek FH, $pos, $whence # seek
+truncate FOO, 42 # truncate
+fcntl # fcntl
+ioctl # ioctl
+flock FOO, 1 # flock
+socket # socket
+socketpair # sockpair
+bind # bind
+connect # connect
+listen # listen
+accept # accept
+shutdown # shutdown
+getsockopt # gsockopt
+setsockopt # ssockopt
+getsockname # getsockname
+getpeername # getpeername
+lstat FOO # lstat
+stat FOO # stat
+-R # ftrread
+-W # ftrwrite
+-X # ftrexec
+-r # fteread
+-w # ftewrite
+-x # fteexec
+-e # ftis
+SKIP -O # fteowned
+SKIP -o # ftrowned
+-z # ftzero
+-s # ftsize
+-M # ftmtime
+-A # ftatime
+-C # ftctime
+-S # ftsock
+-c # ftchr
+-b # ftblk
+-f # ftfile
+-d # ftdir
+-p # ftpipe
+-l # ftlink
+-u # ftsuid
+-g # ftsgid
+-k # ftsvtx
+-t # fttty
+-T # fttext
+-B # ftbinary
+chdir '/' # chdir
+chown # chown
+chroot # chroot
+unlink 'foo' # unlink
+chmod 511, 'foo' # chmod
+utime # utime
+rename 'foo', 'bar' # rename
+link 'foo', 'bar' # link
+symlink 'foo', 'bar' # symlink
+readlink 'foo' # readlink
+mkdir 'foo' # mkdir
+rmdir 'foo' # rmdir
+opendir DIR # open_dir
+readdir DIR # readdir
+telldir DIR # telldir
+seekdir DIR, $pos # seekdir
+rewinddir DIR # rewinddir
+closedir DIR # closedir
+fork # fork
+wait # wait
+waitpid # waitpid
+system # system
+exec # exec
+kill # kill
+getppid # getppid
+getpgrp # getpgrp
+setpgrp # setpgrp
+getpriority # getpriority
+setpriority # setpriority
+time # time
+times # tms
+localtime # localtime
+gmtime # gmtime
+alarm # alarm
+sleep 1 # sleep
+shmget # shmget
+shmctl # shmctl
+shmread # shmread
+shmwrite # shmwrite
+msgget # msgget
+msgctl # msgctl
+msgsnd # msgsnd
+msgrcv # msgrcv
+semget # semget
+semctl # semctl
+semop # semop
+use strict # require
+do 'file' # dofile
+eval "1+1" # entereval
+eval "1+1" # leaveeval
+SKIP eval { 1+1 } # entertry
+SKIP eval { 1+1 } # leavetry
+gethostbyname 'foo' # ghbyname
+gethostbyaddr 'foo' # ghbyaddr
+gethostent # ghostent
+getnetbyname 'foo' # gnbyname
+getnetbyaddr 'foo' # gnbyaddr
+getnetent # gnetent
+getprotobyname 'foo' # gpbyname
+getprotobynumber 42 # gpbynumber
+getprotoent # gprotoent
+getservbyname 'name', 'proto' # gsbyname
+getservbyport 'a', 'b' # gsbyport
+getservent # gservent
+sethostent # shostent
+setnetent # snetent
+setprotoent # sprotoent
+setservent # sservent
+endhostent # ehostent
+endnetent # enetent
+endprotoent # eprotoent
+endservent # eservent
+getpwnam # gpwnam
+getpwuid # gpwuid
+getpwent # gpwent
+setpwent # spwent
+endpwent # epwent
+getgrnam # ggrnam
+getgrgid # ggrgid
+getgrent # ggrent
+setgrent # sgrent
+endgrent # egrent
+getlogin # getlogin
+syscall # syscall
+SKIP # lock
+SKIP # threadsv
+SKIP # setstate
+$x->y() # method_named
+$x // $y # dor
+$x //= $y # dorassign
+SKIP (no way) # custom