home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / closure.t < prev    next >
Text File  |  2000-02-03  |  13KB  |  508 lines
  1. #!./perl
  2. #                              -*- Mode: Perl -*-
  3. # closure.t:
  4. #   Original written by Ulrich Pfeifer on 2 Jan 1997.
  5. #   Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
  6. #
  7.  
  8. BEGIN {
  9.     chdir 't' if -d 't';
  10.     unshift @INC, '../lib';
  11. }
  12.  
  13. use Config;
  14.  
  15. print "1..171\n";
  16.  
  17. my $test = 1;
  18. sub test (&) {
  19.   print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
  20.   $test++;
  21. }
  22.  
  23. my $i = 1;
  24. sub foo { $i = shift if @_; $i }
  25.  
  26. # no closure
  27. test { foo == 1 };
  28. foo(2);
  29. test { foo == 2 };
  30.  
  31. # closure: lexical outside sub
  32. my $foo = sub {$i = shift if @_; $i };
  33. my $bar = sub {$i = shift if @_; $i };
  34. test {&$foo() == 2 };
  35. &$foo(3);
  36. test {&$foo() == 3 };
  37. # did the lexical change?
  38. test { foo == 3 and $i == 3};
  39. # did the second closure notice?
  40. test {&$bar() == 3 };
  41.  
  42. # closure: lexical inside sub
  43. sub bar {
  44.   my $i = shift;
  45.   sub { $i = shift if @_; $i }
  46. }
  47.  
  48. $foo = bar(4);
  49. $bar = bar(5);
  50. test {&$foo() == 4 };
  51. &$foo(6);
  52. test {&$foo() == 6 };
  53. test {&$bar() == 5 };
  54.  
  55. # nested closures
  56. sub bizz {
  57.   my $i = 7;
  58.   if (@_) {
  59.     my $i = shift;
  60.     sub {$i = shift if @_; $i };
  61.   } else {
  62.     my $i = $i;
  63.     sub {$i = shift if @_; $i };
  64.   }
  65. }
  66. $foo = bizz();
  67. $bar = bizz();
  68. test {&$foo() == 7 };
  69. &$foo(8);
  70. test {&$foo() == 8 };
  71. test {&$bar() == 7 };
  72.  
  73. $foo = bizz(9);
  74. $bar = bizz(10);
  75. test {&$foo(11)-1 == &$bar()};
  76.  
  77. my @foo;
  78. for (qw(0 1 2 3 4)) {
  79.   my $i = $_;
  80.   $foo[$_] = sub {$i = shift if @_; $i };
  81. }
  82.  
  83. test {
  84.   &{$foo[0]}() == 0 and
  85.   &{$foo[1]}() == 1 and
  86.   &{$foo[2]}() == 2 and
  87.   &{$foo[3]}() == 3 and
  88.   &{$foo[4]}() == 4
  89.   };
  90.  
  91. for (0 .. 4) {
  92.   &{$foo[$_]}(4-$_);
  93. }
  94.  
  95. test {
  96.   &{$foo[0]}() == 4 and
  97.   &{$foo[1]}() == 3 and
  98.   &{$foo[2]}() == 2 and
  99.   &{$foo[3]}() == 1 and
  100.   &{$foo[4]}() == 0
  101.   };
  102.  
  103. sub barf {
  104.   my @foo;
  105.   for (qw(0 1 2 3 4)) {
  106.     my $i = $_;
  107.     $foo[$_] = sub {$i = shift if @_; $i };
  108.   }
  109.   @foo;
  110. }
  111.  
  112. @foo = barf();
  113. test {
  114.   &{$foo[0]}() == 0 and
  115.   &{$foo[1]}() == 1 and
  116.   &{$foo[2]}() == 2 and
  117.   &{$foo[3]}() == 3 and
  118.   &{$foo[4]}() == 4
  119.   };
  120.  
  121. for (0 .. 4) {
  122.   &{$foo[$_]}(4-$_);
  123. }
  124.  
  125. test {
  126.   &{$foo[0]}() == 4 and
  127.   &{$foo[1]}() == 3 and
  128.   &{$foo[2]}() == 2 and
  129.   &{$foo[3]}() == 1 and
  130.   &{$foo[4]}() == 0
  131.   };
  132.  
  133. # test if closures get created in optimized for loops
  134.  
  135. my %foo;
  136. for my $n ('A'..'E') {
  137.     $foo{$n} = sub { $n eq $_[0] };
  138. }
  139.  
  140. test {
  141.   &{$foo{A}}('A') and
  142.   &{$foo{B}}('B') and
  143.   &{$foo{C}}('C') and
  144.   &{$foo{D}}('D') and
  145.   &{$foo{E}}('E')
  146. };
  147.  
  148. for my $n (0..4) {
  149.     $foo[$n] = sub { $n == $_[0] };
  150. }
  151.  
  152. test {
  153.   &{$foo[0]}(0) and
  154.   &{$foo[1]}(1) and
  155.   &{$foo[2]}(2) and
  156.   &{$foo[3]}(3) and
  157.   &{$foo[4]}(4)
  158. };
  159.  
  160. for my $n (0..4) {
  161.     $foo[$n] = sub {
  162.                      # no intervening reference to $n here
  163.                      sub { $n == $_[0] }
  164.            };
  165. }
  166.  
  167. test {
  168.   $foo[0]->()->(0) and
  169.   $foo[1]->()->(1) and
  170.   $foo[2]->()->(2) and
  171.   $foo[3]->()->(3) and
  172.   $foo[4]->()->(4)
  173. };
  174.  
  175. {
  176.     my $w;
  177.     $w = sub {
  178.     my ($i) = @_;
  179.     test { $i == 10 };
  180.     sub { $w };
  181.     };
  182.     $w->(10);
  183. }
  184.  
  185. # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
  186.  
  187. {
  188.     use strict;
  189.  
  190.     use vars qw!$test!;
  191.     my($debugging, %expected, $inner_type, $where_declared, $within);
  192.     my($nc_attempt, $call_outer, $call_inner, $undef_outer);
  193.     my($code, $inner_sub_test, $expected, $line, $errors, $output);
  194.     my(@inners, $sub_test, $pid);
  195.     $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
  196.  
  197.     # The expected values for these tests
  198.     %expected = (
  199.     'global_scalar'    => 1001,
  200.     'global_array'    => 2101,
  201.     'global_hash'    => 3004,
  202.     'fs_scalar'    => 4001,
  203.     'fs_array'    => 5101,
  204.     'fs_hash'    => 6004,
  205.     'sub_scalar'    => 7001,
  206.     'sub_array'    => 8101,
  207.     'sub_hash'    => 9004,
  208.     'foreach'    => 10011,
  209.     );
  210.  
  211.     # Our innermost sub is either named or anonymous
  212.     for $inner_type (qw!named anon!) {
  213.       # And it may be declared at filescope, within a named
  214.       # sub, or within an anon sub
  215.       for $where_declared (qw!filescope in_named in_anon!) {
  216.     # And that, in turn, may be within a foreach loop,
  217.     # a naked block, or another named sub
  218.     for $within (qw!foreach naked other_sub!) {
  219.  
  220.       # Here are a number of variables which show what's
  221.       # going on, in a way.
  222.       $nc_attempt = 0+        # Named closure attempted
  223.           ( ($inner_type eq 'named') ||
  224.           ($within eq 'other_sub') ) ;
  225.       $call_inner = 0+        # Need to call &inner
  226.           ( ($inner_type eq 'anon') &&
  227.           ($within eq 'other_sub') ) ;
  228.       $call_outer = 0+        # Need to call &outer or &$outer
  229.           ( ($inner_type eq 'anon') &&
  230.           ($within ne 'other_sub') ) ;
  231.       $undef_outer = 0+        # $outer is created but unused
  232.           ( ($where_declared eq 'in_anon') &&
  233.           (not $call_outer) ) ;
  234.  
  235.       $code = "# This is a test script built by t/op/closure.t\n\n";
  236.  
  237.       $code .= <<"DEBUG_INFO" if $debugging;
  238. # inner_type: $inner_type 
  239. # where_declared: $where_declared 
  240. # within: $within
  241. # nc_attempt: $nc_attempt
  242. # call_inner: $call_inner
  243. # call_outer: $call_outer
  244. # undef_outer: $undef_outer
  245. DEBUG_INFO
  246.  
  247.       $code .= <<"END_MARK_ONE";
  248.  
  249. BEGIN { \$SIG{__WARN__} = sub { 
  250.     my \$msg = \$_[0];
  251. END_MARK_ONE
  252.  
  253.       $code .=  <<"END_MARK_TWO" if $nc_attempt;
  254.     return if index(\$msg, 'will not stay shared') != -1;
  255.     return if index(\$msg, 'may be unavailable') != -1;
  256. END_MARK_TWO
  257.  
  258.       $code .= <<"END_MARK_THREE";        # Backwhack a lot!
  259.     print "not ok: got unexpected warning \$msg\\n";
  260. } }
  261.  
  262. {
  263.     my \$test = $test;
  264.     sub test (&) {
  265.       my \$result = &{\$_[0]};
  266.       print "not " unless \$result;
  267.       print "ok \$test\\n";
  268.       \$test++;
  269.     }
  270. }
  271.  
  272. # some of the variables which the closure will access
  273. \$global_scalar = 1000;
  274. \@global_array = (2000, 2100, 2200, 2300);
  275. %global_hash = 3000..3009;
  276.  
  277. my \$fs_scalar = 4000;
  278. my \@fs_array = (5000, 5100, 5200, 5300);
  279. my %fs_hash = 6000..6009;
  280.  
  281. END_MARK_THREE
  282.  
  283.       if ($where_declared eq 'filescope') {
  284.         # Nothing here
  285.       } elsif ($where_declared eq 'in_named') {
  286.         $code .= <<'END';
  287. sub outer {
  288.   my $sub_scalar = 7000;
  289.   my @sub_array = (8000, 8100, 8200, 8300);
  290.   my %sub_hash = 9000..9009;
  291. END
  292.     # }
  293.       } elsif ($where_declared eq 'in_anon') {
  294.         $code .= <<'END';
  295. $outer = sub {
  296.   my $sub_scalar = 7000;
  297.   my @sub_array = (8000, 8100, 8200, 8300);
  298.   my %sub_hash = 9000..9009;
  299. END
  300.     # }
  301.       } else {
  302.         die "What was $where_declared?"
  303.       }
  304.  
  305.       if ($within eq 'foreach') {
  306.         $code .= "
  307.       my \$foreach = 12000;
  308.       my \@list = (10000, 10010);
  309.       foreach \$foreach (\@list) {
  310.     " # }
  311.       } elsif ($within eq 'naked') {
  312.         $code .= "  { # naked block\n"    # }
  313.       } elsif ($within eq 'other_sub') {
  314.         $code .= "  sub inner_sub {\n"    # }
  315.       } else {
  316.         die "What was $within?"
  317.       }
  318.  
  319.       $sub_test = $test;
  320.       @inners = ( qw!global_scalar global_array global_hash! ,
  321.         qw!fs_scalar fs_array fs_hash! );
  322.       push @inners, 'foreach' if $within eq 'foreach';
  323.       if ($where_declared ne 'filescope') {
  324.         push @inners, qw!sub_scalar sub_array sub_hash!;
  325.       }
  326.       for $inner_sub_test (@inners) {
  327.  
  328.         if ($inner_type eq 'named') {
  329.           $code .= "    sub named_$sub_test "
  330.         } elsif ($inner_type eq 'anon') {
  331.           $code .= "    \$anon_$sub_test = sub "
  332.         } else {
  333.           die "What was $inner_type?"
  334.         }
  335.  
  336.         # Now to write the body of the test sub
  337.         if ($inner_sub_test eq 'global_scalar') {
  338.           $code .= '{ ++$global_scalar }'
  339.         } elsif ($inner_sub_test eq 'fs_scalar') {
  340.           $code .= '{ ++$fs_scalar }'
  341.         } elsif ($inner_sub_test eq 'sub_scalar') {
  342.           $code .= '{ ++$sub_scalar }'
  343.         } elsif ($inner_sub_test eq 'global_array') {
  344.           $code .= '{ ++$global_array[1] }'
  345.         } elsif ($inner_sub_test eq 'fs_array') {
  346.           $code .= '{ ++$fs_array[1] }'
  347.         } elsif ($inner_sub_test eq 'sub_array') {
  348.           $code .= '{ ++$sub_array[1] }'
  349.         } elsif ($inner_sub_test eq 'global_hash') {
  350.           $code .= '{ ++$global_hash{3002} }'
  351.         } elsif ($inner_sub_test eq 'fs_hash') {
  352.           $code .= '{ ++$fs_hash{6002} }'
  353.         } elsif ($inner_sub_test eq 'sub_hash') {
  354.           $code .= '{ ++$sub_hash{9002} }'
  355.         } elsif ($inner_sub_test eq 'foreach') {
  356.           $code .= '{ ++$foreach }'
  357.         } else {
  358.           die "What was $inner_sub_test?"
  359.         }
  360.       
  361.         # Close up
  362.         if ($inner_type eq 'anon') {
  363.           $code .= ';'
  364.         }
  365.         $code .= "\n";
  366.         $sub_test++;    # sub name sequence number
  367.  
  368.       } # End of foreach $inner_sub_test
  369.  
  370.       # Close up $within block        # {
  371.       $code .= "  }\n\n";
  372.  
  373.       # Close up $where_declared block
  374.       if ($where_declared eq 'in_named') {    # {
  375.         $code .= "}\n\n";
  376.       } elsif ($where_declared eq 'in_anon') {    # {
  377.         $code .= "};\n\n";
  378.       }
  379.  
  380.       # We may need to do something with the sub we just made...
  381.       $code .= "undef \$outer;\n" if $undef_outer;
  382.       $code .= "&inner_sub;\n" if $call_inner;
  383.       if ($call_outer) {
  384.         if ($where_declared eq 'in_named') {
  385.           $code .= "&outer;\n\n";
  386.         } elsif ($where_declared eq 'in_anon') {
  387.           $code .= "&\$outer;\n\n"
  388.         }
  389.       }
  390.  
  391.       # Now, we can actually prep to run the tests.
  392.       for $inner_sub_test (@inners) {
  393.         $expected = $expected{$inner_sub_test} or
  394.           die "expected $inner_sub_test missing";
  395.  
  396.         # Named closures won't access the expected vars
  397.         if ( $nc_attempt and 
  398.         substr($inner_sub_test, 0, 4) eq "sub_" ) {
  399.           $expected = 1;
  400.         }
  401.  
  402.         # If you make a sub within a foreach loop,
  403.         # what happens if it tries to access the 
  404.         # foreach index variable? If it's a named
  405.         # sub, it gets the var from "outside" the loop,
  406.         # but if it's anon, it gets the value to which
  407.         # the index variable is aliased.
  408.         #
  409.         # Of course, if the value was set only
  410.         # within another sub which was never called,
  411.         # the value has not been set yet.
  412.         #
  413.         if ($inner_sub_test eq 'foreach') {
  414.           if ($inner_type eq 'named') {
  415.         if ($call_outer || ($where_declared eq 'filescope')) {
  416.           $expected = 12001
  417.         } else {
  418.           $expected = 1
  419.         }
  420.           }
  421.         }
  422.  
  423.         # Here's the test:
  424.         if ($inner_type eq 'anon') {
  425.           $code .= "test { &\$anon_$test == $expected };\n"
  426.         } else {
  427.           $code .= "test { &named_$test == $expected };\n"
  428.         }
  429.         $test++;
  430.       }
  431.  
  432.       if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
  433.         # Fork off a new perl to run the tests.
  434.         # (This is so we can catch spurious warnings.)
  435.         $| = 1; print ""; $| = 0; # flush output before forking
  436.         pipe READ, WRITE or die "Can't make pipe: $!";
  437.         pipe READ2, WRITE2 or die "Can't make second pipe: $!";
  438.         die "Can't fork: $!" unless defined($pid = open PERL, "|-");
  439.         unless ($pid) {
  440.           # Child process here. We're going to send errors back
  441.           # through the extra pipe.
  442.           close READ;
  443.           close READ2;
  444.           open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
  445.           open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
  446.           exec './perl', '-w', '-'
  447.         or die "Can't exec ./perl: $!";
  448.         } else {
  449.           # Parent process here.
  450.           close WRITE;
  451.           close WRITE2;
  452.           print PERL $code;
  453.           close PERL;
  454.           { local $/;
  455.             $output = join '', <READ>;
  456.             $errors = join '', <READ2>; }
  457.           close READ;
  458.           close READ2;
  459.         }
  460.       } else {
  461.         # No fork().  Do it the hard way.
  462.         my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
  463.         my $errfile = "terr$$";  $errfile++ while -e $errfile;
  464.         my @tmpfiles = ($cmdfile, $errfile);
  465.         open CMD, ">$cmdfile"; print CMD $code; close CMD;
  466.         my $cmd = (($^O eq 'VMS') ? "MCR $^X"
  467.                : ($^O eq 'MSWin32') ? '.\perl'
  468.                : './perl');
  469.         $cmd .= " -w $cmdfile 2>$errfile";
  470.         if ($^O eq 'VMS' or $^O eq 'MSWin32') {
  471.           # Use pipe instead of system so we don't inherit STD* from
  472.           # this process, and then foul our pipe back to parent by
  473.           # redirecting output in the child.
  474.           open PERL,"$cmd |" or die "Can't open pipe: $!\n";
  475.           { local $/; $output = join '', <PERL> }
  476.           close PERL;
  477.         } else {
  478.           my $outfile = "tout$$";  $outfile++ while -e $outfile;
  479.           push @tmpfiles, $outfile;
  480.           system "$cmd >$outfile";
  481.           { local $/; open IN, $outfile; $output = <IN>; close IN }
  482.         }
  483.         if ($?) {
  484.           printf "not ok: exited with error code %04X\n", $?;
  485.           $debugging or do { 1 while unlink @tmpfiles };
  486.           exit;
  487.         }
  488.         { local $/; open IN, $errfile; $errors = <IN>; close IN }
  489.         1 while unlink @tmpfiles;
  490.       }
  491.       print $output;
  492.       print STDERR $errors;
  493.       if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
  494.         my $lnum = 0;
  495.         for $line (split '\n', $code) {
  496.           printf "%3d:  %s\n", ++$lnum, $line;
  497.         }
  498.       }
  499.       printf "not ok: exited with error code %04X\n", $? if $?;
  500.       print "-" x 30, "\n" if $debugging;
  501.  
  502.     }    # End of foreach $within
  503.       }    # End of foreach $where_declared
  504.     }    # End of foreach $inner_type
  505.  
  506. }
  507.  
  508.