Commit | Line | Data |
9d5fa2fe |
1 | #!perl -w |
576b33a1 |
2 | $|=1; |
3 | BEGIN { |
576b33a1 |
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 |
13 | |
14 | my $safe = Safe->new('PLPerl'); |
15 | $safe->permit_only(qw(:default sort)); |
16 | |
32f28238 |
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 |
23 | |
24 | # uses quotes in { "$a" <=> $b } to avoid the optimizer replacing the block |
25 | # with a hardwired comparison |
32f28238 |
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 |
30 | |
31 | EOS |
32 | |
33 | is $@, '', 'reval should not fail'; |
34 | is ref $func, 'CODE', 'reval should return a CODE ref'; |
35 | |
27c4ce72 |
36 | # $func1 will work in non-threaded perl |
37 | # but RT#60374 "Safe.pm sort {} bug with -Dusethreads" |
38 | # means the sorting won't work unless we wrap the code ref |
39 | # such that it's executed with Safe 'in effect' at runtime |
40 | my $func2 = $safe->wrap_code_ref($func1); |
41 | |
42 | my ($l_sorted, $p_sorted) = $func2->(3,1,2); |
576b33a1 |
43 | is $l_sorted, "1,2,3"; |
44 | is $p_sorted, "1,2,3"; |
2630fd9e |
45 | |
46 | # check other aspects of closures created inside Safe |
47 | |
48 | my $die_func = $safe->reval(q{ sub { die @_ if @_; 1 } }); |
49 | |
50 | # check $@ not affected by successful call |
51 | $@ = 42; |
52 | $die_func->(); |
53 | is $@, 42, 'successful closure call should not alter $@'; |
54 | |
fda8057a |
55 | { |
56 | my $warns = 0; |
57 | local $SIG{__WARN__} = sub { $warns++ }; |
58 | ok !eval { $die_func->("died\n"); 1 }, 'should die'; |
59 | is $@, "died\n", '$@ should be set correctly'; |
60 | local $TODO = "Shouldn't warn"; |
61 | is $warns, 0; |
62 | } |