dist/Safe/t/safesort.t

   1 #!perl -w
   2 $|=1;
   3 BEGIN {
   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;
  12 use Test::More tests => 10;
  13
  14 my $safe = Safe->new('PLPerl');
  15 $safe->permit_only(qw(:default sort));
  16
  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
  22 $func = $safe->reval(<<'EOS');
  23
  24     # uses quotes in { "$a" <=> $b } to avoid the optimizer replacing the block
  25     # with a hardwired comparison
  26     { package Pkg; sub p_sort { return sort { "$a" <=> $b } @_; } }
  27                    sub l_sort { return sort { "$a" <=> $b } @_; }
  28
  29     return sub { return join(",",l_sort(@_)), join(",",Pkg::p_sort(@_)) }
  30
  31 EOS
  32
  33 is $@, '', 'reval should not fail';
  34 is ref $func, 'CODE', 'reval should return a CODE ref';
  35
  36 my ($l_sorted, $p_sorted) = $func->(1,2,3);
  37 is $l_sorted, "1,2,3";
  38 is $p_sorted, "1,2,3";
  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
  49 {
  50     my $warns = 0;
  51     local $SIG{__WARN__} = sub { $warns++ };
  52     ok !eval { $die_func->("died\n"); 1 }, 'should die';
  53     is $@, "died\n", '$@ should be set correctly';
  54     local $TODO = "Shouldn't warn";
  55     is $warns, 0;
  56 }