t/op/anonsub.t

   1 #!./perl
   2
   3 chdir 't' if -d 't';
   4 @INC = '../lib';
   5 $Is_VMS = $^O eq 'VMS';
   6 $Is_MSWin32 = $^O eq 'MSWin32';
   7 $Is_MacOS = $^O eq 'MacOS';
   8 $Is_NetWare = $^O eq 'NetWare';
   9 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
  10
  11 $|=1;
  12
  13 undef $/;
  14 @prgs = split "\n########\n", <DATA>;
  15 print "1..", scalar @prgs, "\n";
  16
  17 $tmpfile = "asubtmp000";
  18 1 while -f ++$tmpfile;
  19 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
  20
  21 for (@prgs){
  22     my $switch = "";
  23     if (s/^\s*(-\w+)//){
  24        $switch = $1;
  25     }
  26     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  27     open TEST, ">$tmpfile";
  28     print TEST "$prog\n";
  29     close TEST or die "Could not close: $!";
  30     my $results = $Is_VMS ?
  31                 `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
  32                   $Is_MSWin32 ?
  33                     `.\\perl -I../lib $switch $tmpfile 2>&1` :
  34                       $Is_MacOS ?
  35                         `$^X -I::lib $switch $tmpfile` :
  36                             $Is_NetWare ?
  37                                 `perl -I../lib $switch $tmpfile 2>&1` :
  38                                     `./perl $switch $tmpfile 2>&1`;
  39     my $status = $?;
  40     $results =~ s/\n+$//;
  41     # allow expected output to be written as if $prog is on STDIN
  42     $results =~ s/runltmp\d+/-/g;
  43     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  44     $expected =~ s/\n+$//;
  45     if ($results ne $expected) {
  46        print STDERR "PROG: $switch\n$prog\n";
  47        print STDERR "EXPECTED:\n$expected\n";
  48        print STDERR "GOT:\n$results\n";
  49        print "not ";
  50     }
  51     print "ok ", ++$i, "\n";
  52 }
  53
  54 __END__
  55 sub X {
  56     my $n = "ok 1\n";
  57     sub { print $n };
  58 }
  59 my $x = X();
  60 undef &X;
  61 $x->();
  62 EXPECT
  63 ok 1
  64 ########
  65 sub X {
  66     my $n = "ok 1\n";
  67     sub {
  68         my $dummy = $n; # eval can't close on $n without internal reference
  69         eval 'print $n';
  70         die $@ if $@;
  71     };
  72 }
  73 my $x = X();
  74 undef &X;
  75 $x->();
  76 EXPECT
  77 ok 1
  78 ########
  79 sub X {
  80     my $n = "ok 1\n";
  81     eval 'sub { print $n }';
  82 }
  83 my $x = X();
  84 die $@ if $@;
  85 undef &X;
  86 $x->();
  87 EXPECT
  88 ok 1
  89 ########
  90 sub X;
  91 sub X {
  92     my $n = "ok 1\n";
  93     eval 'sub Y { my $p = shift; $p->() }';
  94     die $@ if $@;
  95     Y(sub { print $n });
  96 }
  97 X();
  98 EXPECT
  99 ok 1
 100 ########
 101 package;
 102 print sub { return "ok 1\n" } -> ();
 103 EXPECT
 104 ok 1