t/op/anonsub.t

   1 #!./perl
   2
   3 # Note : we're not using t/test.pl here, because we would need
   4 # fresh_perl_is, and fresh_perl_is uses a closure -- a special
   5 # case of what this program tests for.
   6
   7 chdir 't' if -d 't';
   8 @INC = '../lib';
   9 $Is_VMS = $^O eq 'VMS';
  10 $Is_MSWin32 = $^O eq 'MSWin32';
  11 $Is_MacOS = $^O eq 'MacOS';
  12 $Is_NetWare = $^O eq 'NetWare';
  13 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
  14
  15 $|=1;
  16
  17 undef $/;
  18 @prgs = split "\n########\n", <DATA>;
  19 print "1..", 6 + scalar @prgs, "\n";
  20
  21 $tmpfile = "asubtmp000";
  22 1 while -f ++$tmpfile;
  23 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
  24
  25 for (@prgs){
  26     my $switch = "";
  27     if (s/^\s*(-\w+)//){
  28        $switch = $1;
  29     }
  30     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  31     open TEST, ">$tmpfile";
  32     print TEST "$prog\n";
  33     close TEST or die "Could not close: $!";
  34     my $results = $Is_VMS ?
  35                 `$^X "-I[-.lib]" $switch $tmpfile 2>&1` :
  36                   $Is_MSWin32 ?
  37                     `.\\perl -I../lib $switch $tmpfile 2>&1` :
  38                       $Is_MacOS ?
  39                         `$^X -I::lib $switch $tmpfile` :
  40                             $Is_NetWare ?
  41                                 `perl -I../lib $switch $tmpfile 2>&1` :
  42                                     `./perl $switch $tmpfile 2>&1`;
  43     my $status = $?;
  44     $results =~ s/\n+$//;
  45     # allow expected output to be written as if $prog is on STDIN
  46     $results =~ s/runltmp\d+/-/g;
  47     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  48     $expected =~ s/\n+$//;
  49     if ($results ne $expected) {
  50        print STDERR "PROG: $switch\n$prog\n";
  51        print STDERR "EXPECTED:\n$expected\n";
  52        print STDERR "GOT:\n$results\n";
  53        print "not ";
  54     }
  55     print "ok ", ++$i, "\n";
  56 }
  57
  58 sub test_invalid_decl {
  59     my ($code,$todo) = @_;
  60     $todo //= '';
  61     eval $code;
  62     if ($@ =~ /^Illegal declaration of anonymous subroutine at/) {
  63         print "ok ", ++$i, " - '$code' is illegal$todo\n";
  64     } else {
  65         print "not ok ", ++$i, " - '$code' is illegal$todo\n# GOT: $@";
  66     }
  67 }
  68
  69 test_invalid_decl('sub;');
  70 test_invalid_decl('sub ($) ;');
  71 test_invalid_decl('{ $x = sub }');
  72 test_invalid_decl('sub ($) && 1');
  73 test_invalid_decl('sub ($) : lvalue;',' # TODO');
  74
  75 eval "sub #foo\n{print 1}";
  76 if ($@ eq '') {
  77     print "ok ", ++$i, "\n";
  78 } else {
  79     print "not ok ", ++$i, "\n# GOT: $@";
  80 }
  81
  82 __END__
  83 sub X {
  84     my $n = "ok 1\n";
  85     sub { print $n };
  86 }
  87 my $x = X();
  88 undef &X;
  89 $x->();
  90 EXPECT
  91 ok 1
  92 ########
  93 sub X {
  94     my $n = "ok 1\n";
  95     sub {
  96         my $dummy = $n; # eval can't close on $n without internal reference
  97         eval 'print $n';
  98         die $@ if $@;
  99     };
 100 }
 101 my $x = X();
 102 undef &X;
 103 $x->();
 104 EXPECT
 105 ok 1
 106 ########
 107 sub X {
 108     my $n = "ok 1\n";
 109     eval 'sub { print $n }';
 110 }
 111 my $x = X();
 112 die $@ if $@;
 113 undef &X;
 114 $x->();
 115 EXPECT
 116 ok 1
 117 ########
 118 sub X;
 119 sub X {
 120     my $n = "ok 1\n";
 121     eval 'sub Y { my $p = shift; $p->() }';
 122     die $@ if $@;
 123     Y(sub { print $n });
 124 }
 125 X();
 126 EXPECT
 127 ok 1
 128 ########
 129 print sub { return "ok 1\n" } -> ();
 130 EXPECT
 131 ok 1