diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
commit | b695f709e8a342e35e482b0437eb6cdacdc58b6b (patch) | |
tree | 2d16192636e6ba806ff7a907f682c74f7705a920 /ext/Safe | |
parent | d780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff) | |
download | perl-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-x | ext/Safe/safe1.t | 68 | ||||
-rwxr-xr-x | ext/Safe/safe2.t | 145 |
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 } |