Commit | Line | Data |
---|---|---|
9d5fa2fe | 1 | #!perl -w |
576b33a1 TB |
2 | $|=1; |
3 | BEGIN { | |
576b33a1 TB |
4 | require Config; import Config; |
5 | if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { | |
6 | print "1..0\n"; | |
7 | exit 0; | |
8 | } | |
9 | } | |
10 | ||
11 | use Safe 1.00; | |
fda8057a | 12 | use Test::More tests => 10; |
576b33a1 TB |
13 | |
14 | my $safe = Safe->new('PLPerl'); | |
15 | $safe->permit_only(qw(:default sort)); | |
16 | ||
32f28238 TB |
17 | # check basic argument passing and context for anon-subs |
18 | my $func = $safe->reval(q{ sub { @_ } }); | |
19 | is_deeply [ $func->() ], [ ]; | |
20 | is_deeply [ $func->("foo") ], [ "foo" ]; | |
21 | ||
27c4ce72 | 22 | my $func1 = $safe->reval(<<'EOS'); |
576b33a1 TB |
23 | |
24 | # uses quotes in { "$a" <=> $b } to avoid the optimizer replacing the block | |
25 | # with a hardwired comparison | |
32f28238 TB |
26 | { package Pkg; sub p_sort { return sort { "$a" <=> $b } @_; } } |
27 | sub l_sort { return sort { "$a" <=> $b } @_; } | |
576b33a1 | 28 | |
32f28238 | 29 | return sub { return join(",",l_sort(@_)), join(",",Pkg::p_sort(@_)) } |
576b33a1 TB |
30 | |
31 | EOS | |
32 | ||
33 | is $@, '', 'reval should not fail'; | |
34 | is ref $func, 'CODE', 'reval should return a CODE ref'; | |
35 | ||
55454543 | 36 | my ($l_sorted, $p_sorted) = $func1->(3,1,2); |
576b33a1 TB |
37 | is $l_sorted, "1,2,3"; |
38 | is $p_sorted, "1,2,3"; | |
2630fd9e TB |
39 | |
40 | # check other aspects of closures created inside Safe | |
41 | ||
42 | my $die_func = $safe->reval(q{ sub { die @_ if @_; 1 } }); | |
43 | ||
44 | # check $@ not affected by successful call | |
45 | $@ = 42; | |
46 | $die_func->(); | |
47 | is $@, 42, 'successful closure call should not alter $@'; | |
48 | ||
fda8057a RGS |
49 | { |
50 | my $warns = 0; | |
51 | local $SIG{__WARN__} = sub { $warns++ }; | |
c919e873 | 52 | local $TODO = $] >= 5.013 ? "Doesn't die in 5.13" : undef; |
fda8057a RGS |
53 | ok !eval { $die_func->("died\n"); 1 }, 'should die'; |
54 | is $@, "died\n", '$@ should be set correctly'; | |
6d72cea0 | 55 | local $TODO = "Shouldn't warn"; |
fda8057a RGS |
56 | is $warns, 0; |
57 | } |