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