summaryrefslogtreecommitdiff
path: root/ext/Safe
diff options
context:
space:
mode:
authorJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
commitb695f709e8a342e35e482b0437eb6cdacdc58b6b (patch)
tree2d16192636e6ba806ff7a907f682c74f7705a920 /ext/Safe
parentd780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff)
downloadperl-b695f709e8a342e35e482b0437eb6cdacdc58b6b.tar.gz
The Grand Trek: move the *.t files from t/ to lib/ and ext/.
No doubt I made some mistakes like missed some files or misnamed some files. The naming rules were more or less: (1) if the module is from CPAN, follows its ways, be it t/*.t or test.pl. (2) otherwise if there are multiple tests for a module put them in a t/ (3) otherwise if there's only one test put it in Module.t (4) helper files go to module/ (locale, strict, warnings) (5) use longer filenames now that we can (but e.g. the compat-0.6.t and the Text::Balanced test files still were renamed to be more civil against the 8.3 people) installperl was updated appropriately not to install the *.t files or the help files from under lib. TODO: some helper files still remain under t/ that could follow their 'masters'. UPDATE: On second thoughts, why should they. They can continue to live under t/lib, and in fact the locale/strict/warnings helpers that were moved could be moved back. This way the amount of non-installable stuff under lib/ stays smaller. p4raw-id: //depot/perl@10676
Diffstat (limited to 'ext/Safe')
-rwxr-xr-xext/Safe/safe1.t68
-rwxr-xr-xext/Safe/safe2.t145
2 files changed, 213 insertions, 0 deletions
diff --git a/ext/Safe/safe1.t b/ext/Safe/safe1.t
new file mode 100755
index 0000000000..27993d95c9
--- /dev/null
+++ b/ext/Safe/safe1.t
@@ -0,0 +1,68 @@
+#!./perl -w
+$|=1;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+# Tests Todo:
+# 'main' as root
+
+package test; # test from somewhere other than main
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+my $t = 1;
+my $cpt;
+# create and destroy some automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root" or die;
+
+foreach(1..3) {
+ $foo = 42;
+
+ $cpt->share(qw($foo));
+
+ print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ ${$cpt->varglob('foo')} = 9;
+
+ print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check 'main' has been changed:
+ print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check we can't see our test package:
+ print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+ print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ $cpt->erase; # erase the compartment, e.g., delete all variables
+
+ print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ # Note that we *must* use $cpt->varglob here because if we used
+ # $Root::foo etc we would still see the original values!
+ # This seems to be because the compiler has created an extra ref.
+
+ print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++;
+}
+
+print "ok $last_test\n";
+BEGIN { $last_test = 28 }
diff --git a/ext/Safe/safe2.t b/ext/Safe/safe2.t
new file mode 100755
index 0000000000..4d6c84a692
--- /dev/null
+++ b/ext/Safe/safe2.t
@@ -0,0 +1,145 @@
+#!./perl -w
+$|=1;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ # test 30 rather naughtily expects English error messages
+ $ENV{'LC_ALL'} = 'C';
+ $ENV{LANGUAGE} = 'C'; # GNU locale extension
+}
+
+# Tests Todo:
+# 'main' as root
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+# Set up a package namespace of things to be visible to the unsafe code
+$Root::foo = "visible";
+$bar = "invisible";
+
+# Stop perl from moaning about identifies which are apparently only used once
+$Root::foo .= "";
+
+my $cpt;
+# create and destroy a couple of automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root";
+
+$cpt->reval(q{ system("echo not ok 1"); });
+if ($@ =~ /^system trapped by operation mask/) {
+ print "ok 1\n";
+} else {
+ print "#$@" if $@;
+ print "not ok 1\n";
+}
+
+$cpt->reval(q{
+ print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
+ print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
+ print defined($bar) ? "not ok 4\n" : "ok 4\n";
+ print defined($::bar) ? "not ok 5\n" : "ok 5\n";
+ print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
+});
+print $@ ? "not ok 7\n#$@" : "ok 7\n";
+
+$foo = "ok 8\n";
+%bar = (key => "ok 9\n");
+@baz = (); push(@baz, "o", "10"); $" = 'k ';
+$glob = "ok 11\n";
+@glob = qw(not ok 16);
+
+sub sayok { print "ok @_\n" }
+
+$cpt->share(qw($foo %bar @baz *glob sayok));
+$cpt->share('$"') unless $Config{use5005threads};
+
+$cpt->reval(q{
+ package other;
+ sub other_sayok { print "ok @_\n" }
+ package main;
+ print $foo ? $foo : "not ok 8\n";
+ print $bar{key} ? $bar{key} : "not ok 9\n";
+ (@baz) ? print "@baz\n" : print "not ok 10\n";
+ print $glob;
+ other::other_sayok(12);
+ $foo =~ s/8/14/;
+ $bar{new} = "ok 15\n";
+ @glob = qw(ok 16);
+});
+print $@ ? "not ok 13\n#$@" : "ok 13\n";
+$" = ' ';
+print $foo, $bar{new}, "@glob\n";
+
+$Root::foo = "not ok 17";
+@{$cpt->varglob('bar')} = qw(not ok 18);
+${$cpt->varglob('foo')} = "ok 17";
+@Root::bar = "ok";
+push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
+
+print "$Root::foo\n";
+print "@{$cpt->varglob('bar')}\n";
+
+use strict;
+
+print 1 ? "ok 19\n" : "not ok 19\n";
+print 1 ? "ok 20\n" : "not ok 20\n";
+
+my $m1 = $cpt->mask;
+$cpt->trap("negate");
+my $m2 = $cpt->mask;
+my @masked = opset_to_ops($m1);
+print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
+
+print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
+
+print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
+
+$cpt->mask(empty_opset);
+my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
+print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
+my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
+print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
+
+my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
+print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
+print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
+
+# --- rdo
+
+my $t = 30;
+$cpt->rdo('/non/existant/file.name');
+# The regexp is getting rather baroque.
+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++;
+# test #31 is gone.
+print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+
+#my $rdo_file = "tmp_rdo.tpl";
+#if (open X,">$rdo_file") {
+# print X "999\n";
+# close X;
+# $cpt->permit_only('const', 'leaveeval');
+# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
+# unlink $rdo_file;
+#}
+#else {
+# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
+#}
+
+
+print "ok $last_test\n";
+BEGIN { $last_test = 32 }