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