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 $_->[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__
 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 multideref      SKIP (set by optimizer)
 239 unpack          unpack
 240 pack            pack
 241 split           split /foo/
 242 join            join $a, @b
 243 list            @x = (1,2)
 244 lslice          SKIP @x[1,2]
 245 anonlist        [1,2]
 246 anonhash        { a => 1 }
 247 splice          splice @x, 1, 2, 3
 248 push            push @x, $x
 249 pop             pop @x
 250 shift           shift @x
 251 unshift         unshift @x
 252 sort            sort @x
 253 reverse         reverse @x
 254 grepstart       grep { $_ eq 'foo' } @x
 255 grepwhile       SKIP grep { $_ eq 'foo' } @x
 256 mapstart        map $_ + 1, @foo
 257 mapwhile        SKIP (set by optimizer)
 258 range           SKIP
 259 flip            1..2
 260 flop            1..2
 261 and             $x && $y
 262 or              $x || $y
 263 xor             $x xor $y
 264 cond_expr       $x ? 1 : 0
 265 andassign       $x &&= $y
 266 orassign        $x ||= $y
 267 method          Foo->$x()
 268 entersub        f()
 269 leavesub        sub f{} f()
 270 leavesublv      sub f:lvalue{return $x} f()
 271 caller          caller
 272 warn            warn
 273 die             die
 274 reset           reset
 275 lineseq         SKIP
 276 nextstate       SKIP
 277 dbstate         SKIP (needs debugger)
 278 unstack         while(0){}
 279 enter           SKIP
 280 leave           SKIP
 281 scope           SKIP
 282 enteriter       SKIP
 283 iter            SKIP
 284 enterloop       SKIP
 285 leaveloop       SKIP
 286 return          return
 287 last            last
 288 next            next
 289 redo            redo THIS
 290 dump            dump
 291 goto            goto THERE
 292 exit            exit 0
 293 open            open FOO
 294 close           close FOO
 295 pipe_op         pipe FOO,BAR
 296 fileno          fileno FOO
 297 umask           umask 0755, 'foo'
 298 binmode         binmode FOO
 299 tie             tie
 300 untie           untie
 301 tied            tied
 302 dbmopen         dbmopen
 303 dbmclose        dbmclose
 304 sselect         SKIP (set by optimizer)
 305 select          select FOO
 306 getc            getc FOO
 307 read            read FOO
 308 enterwrite      write
 309 leavewrite      SKIP
 310 prtf            printf
 311 print           print
 312 sysopen         sysopen
 313 sysseek         sysseek
 314 sysread         sysread
 315 syswrite        syswrite
 316 send            send
 317 recv            recv
 318 eof             eof FOO
 319 tell            tell
 320 seek            seek FH, $pos, $whence
 321 truncate        truncate FOO, 42
 322 fcntl           fcntl
 323 ioctl           ioctl
 324 flock           flock FOO, 1
 325 socket          socket
 326 sockpair        socketpair
 327 bind            bind
 328 connect         connect
 329 listen          listen
 330 accept          accept
 331 shutdown        shutdown
 332 gsockopt        getsockopt
 333 ssockopt        setsockopt
 334 getsockname     getsockname
 335 getpeername     getpeername
 336 lstat           lstat FOO
 337 stat            stat FOO
 338 ftrread         -R
 339 ftrwrite        -W
 340 ftrexec         -X
 341 fteread         -r
 342 ftewrite        -w
 343 fteexec         -x
 344 ftis            -e
 345 fteowned        SKIP -O
 346 ftrowned        SKIP -o
 347 ftzero          -z
 348 ftsize          -s
 349 ftmtime         -M
 350 ftatime         -A
 351 ftctime         -C
 352 ftsock          -S
 353 ftchr           -c
 354 ftblk           -b
 355 ftfile          -f
 356 ftdir           -d
 357 ftpipe          -p
 358 ftlink          -l
 359 ftsuid          -u
 360 ftsgid          -g
 361 ftsvtx          -k
 362 fttty           -t
 363 fttext          -T
 364 ftbinary        -B
 365 chdir           chdir '/'
 366 chown           chown
 367 chroot          chroot
 368 unlink          unlink 'foo'
 369 chmod           chmod 511, 'foo'
 370 utime           utime
 371 rename          rename 'foo', 'bar'
 372 link            link 'foo', 'bar'
 373 symlink         symlink 'foo', 'bar'
 374 readlink        readlink 'foo'
 375 mkdir           mkdir 'foo'
 376 rmdir           rmdir 'foo'
 377 open_dir        opendir DIR
 378 readdir         readdir DIR
 379 telldir         telldir DIR
 380 seekdir         seekdir DIR, $pos
 381 rewinddir       rewinddir DIR
 382 closedir        closedir DIR
 383 fork            fork
 384 wait            wait
 385 waitpid         waitpid
 386 system          system
 387 exec            exec
 388 kill            kill
 389 getppid         getppid
 390 getpgrp         getpgrp
 391 setpgrp         setpgrp
 392 getpriority     getpriority
 393 setpriority     setpriority
 394 time            time
 395 tms             times
 396 localtime       localtime
 397 gmtime          gmtime
 398 alarm           alarm
 399 sleep           sleep 1
 400 shmget          shmget
 401 shmctl          shmctl
 402 shmread         shmread
 403 shmwrite        shmwrite
 404 msgget          msgget
 405 msgctl          msgctl
 406 msgsnd          msgsnd
 407 msgrcv          msgrcv
 408 semget          semget
 409 semctl          semctl
 410 semop           semop
 411 require         use strict
 412 dofile          do 'file'
 413 entereval       eval "1+1"
 414 leaveeval       eval "1+1"
 415 entertry        SKIP eval { 1+1 }
 416 leavetry        SKIP eval { 1+1 }
 417 ghbyname        gethostbyname 'foo'
 418 ghbyaddr        gethostbyaddr 'foo'
 419 ghostent        gethostent
 420 gnbyname        getnetbyname 'foo'
 421 gnbyaddr        getnetbyaddr 'foo'
 422 gnetent         getnetent
 423 gpbyname        getprotobyname 'foo'
 424 gpbynumber      getprotobynumber 42
 425 gprotoent       getprotoent
 426 gsbyname        getservbyname 'name', 'proto'
 427 gsbyport        getservbyport 'a', 'b'
 428 gservent        getservent
 429 shostent        sethostent
 430 snetent         setnetent
 431 sprotoent       setprotoent
 432 sservent        setservent
 433 ehostent        endhostent
 434 enetent         endnetent
 435 eprotoent       endprotoent
 436 eservent        endservent
 437 gpwnam          getpwnam
 438 gpwuid          getpwuid
 439 gpwent          getpwent
 440 spwent          setpwent
 441 epwent          endpwent
 442 ggrnam          getgrnam
 443 ggrgid          getgrgid
 444 ggrent          getgrent
 445 sgrent          setgrent
 446 egrent          endgrent
 447 getlogin        getlogin
 448 syscall         syscall
 449 lock            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      no warnings 'experimental::smartmatch'; $x ~~ $y
 457 aeach           SKIP each @t
 458 akeys           SKIP keys @t
 459 avalues         SKIP values @t
 460 custom          SKIP (no way)