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