home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / safe2.t < prev    next >
Text File  |  2000-02-18  |  4KB  |  146 lines
  1. #!./perl -w
  2. $|=1;
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     require Config; import Config;
  7.     if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
  8.         print "1..0\n";
  9.         exit 0;
  10.     }
  11.     # test 30 rather naughtily expects English error messages
  12.     $ENV{'LC_ALL'} = 'C';
  13.     $ENV{LANGUAGE} = 'C'; # GNU locale extension
  14. }
  15.  
  16. # Tests Todo:
  17. #    'main' as root
  18.  
  19. use vars qw($bar);
  20.  
  21. use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
  22.     opmask_add full_opset empty_opset opcodes opmask define_optag);
  23.  
  24. use Safe 1.00;
  25.  
  26. my $last_test; # initalised at end
  27. print "1..$last_test\n";
  28.  
  29. # Set up a package namespace of things to be visible to the unsafe code
  30. $Root::foo = "visible";
  31. $bar = "invisible";
  32.  
  33. # Stop perl from moaning about identifies which are apparently only used once
  34. $Root::foo .= "";
  35.  
  36. my $cpt;
  37. # create and destroy a couple of automatic Safe compartments first
  38. $cpt = new Safe or die;
  39. $cpt = new Safe or die;
  40.  
  41. $cpt = new Safe "Root";
  42.  
  43. $cpt->reval(q{ system("echo not ok 1"); });
  44. if ($@ =~ /^system trapped by operation mask/) {
  45.     print "ok 1\n";
  46. } else {
  47.     print "#$@" if $@;
  48.     print "not ok 1\n";
  49. }
  50.  
  51. $cpt->reval(q{
  52.     print $foo eq 'visible'        ? "ok 2\n" : "not ok 2\n";
  53.     print $main::foo  eq 'visible'    ? "ok 3\n" : "not ok 3\n";
  54.     print defined($bar)            ? "not ok 4\n" : "ok 4\n";
  55.     print defined($::bar)        ? "not ok 5\n" : "ok 5\n";
  56.     print defined($main::bar)        ? "not ok 6\n" : "ok 6\n";
  57. });
  58. print $@ ? "not ok 7\n#$@" : "ok 7\n";
  59.  
  60. $foo = "ok 8\n";
  61. %bar = (key => "ok 9\n");
  62. @baz = (); push(@baz, "o", "10"); $" = 'k ';
  63. $glob = "ok 11\n";
  64. @glob = qw(not ok 16);
  65.  
  66. sub sayok { print "ok @_\n" }
  67.  
  68. $cpt->share(qw($foo %bar @baz *glob sayok));
  69. $cpt->share('$"') unless $Config{use5005threads};
  70.  
  71. $cpt->reval(q{
  72.     package other;
  73.     sub other_sayok { print "ok @_\n" }
  74.     package main;
  75.     print $foo ? $foo : "not ok 8\n";
  76.     print $bar{key} ? $bar{key} : "not ok 9\n";
  77.     (@baz) ? print "@baz\n" : print "not ok 10\n";
  78.     print $glob;
  79.     other::other_sayok(12);
  80.     $foo =~ s/8/14/;
  81.     $bar{new} = "ok 15\n";
  82.     @glob = qw(ok 16);
  83. });
  84. print $@ ? "not ok 13\n#$@" : "ok 13\n";
  85. $" = ' ';
  86. print $foo, $bar{new}, "@glob\n";
  87.  
  88. $Root::foo = "not ok 17";
  89. @{$cpt->varglob('bar')} = qw(not ok 18);
  90. ${$cpt->varglob('foo')} = "ok 17";
  91. @Root::bar = "ok";
  92. push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
  93.  
  94. print "$Root::foo\n";
  95. print "@{$cpt->varglob('bar')}\n";
  96.  
  97. use strict;
  98.  
  99. print 1 ? "ok 19\n" : "not ok 19\n";
  100. print 1 ? "ok 20\n" : "not ok 20\n";
  101.  
  102. my $m1 = $cpt->mask;
  103. $cpt->trap("negate");
  104. my $m2 = $cpt->mask;
  105. my @masked = opset_to_ops($m1);
  106. print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
  107.  
  108. print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
  109.  
  110. print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
  111.  
  112. $cpt->mask(empty_opset);
  113. my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
  114. print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
  115. my @t_array  = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
  116. print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
  117.  
  118. my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
  119. print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
  120. print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
  121.  
  122. # --- rdo
  123.   
  124. my $t = 30;
  125. $cpt->rdo('/non/existant/file.name');
  126. # The regexp is getting rather baroque.
  127. print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++;
  128. # test #31 is gone.
  129. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
  130.   
  131. #my $rdo_file = "tmp_rdo.tpl";
  132. #if (open X,">$rdo_file") {
  133. #    print X "999\n";
  134. #    close X;
  135. #    $cpt->permit_only('const', 'leaveeval');
  136. #    print  $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
  137. #    unlink $rdo_file;
  138. #}
  139. #else {
  140. #    print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
  141. #}
  142.  
  143.  
  144. print "ok $last_test\n";
  145. BEGIN { $last_test = 32 }
  146.