home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / eval.t < prev    next >
Text File  |  2000-03-11  |  4KB  |  209 lines
  1. #!./perl
  2.  
  3. print "1..40\n";
  4.  
  5. eval 'print "ok 1\n";';
  6.  
  7. if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  8.  
  9. eval "\$foo\n    = # this is a comment\n'ok 3';";
  10. print $foo,"\n";
  11.  
  12. eval "\$foo\n    = # this is a comment\n'ok 4\n';";
  13. print $foo;
  14.  
  15. print eval '
  16. $foo =;';        # this tests for a call through yyerror()
  17. if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
  18.  
  19. print eval '$foo = /';    # this tests for a call through fatal()
  20. if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
  21.  
  22. print eval '"ok 7\n";';
  23.  
  24. # calculate a factorial with recursive evals
  25.  
  26. $foo = 5;
  27. $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  28. $ans = eval $fact;
  29. if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
  30.  
  31. $foo = 5;
  32. $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  33. $ans = eval $fact;
  34. if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
  35.  
  36. open(try,'>Op.eval');
  37. print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
  38. close try;
  39.  
  40. do 'Op.eval'; print $@;
  41.  
  42. # Test the singlequoted eval optimizer
  43.  
  44. $i = 11;
  45. for (1..3) {
  46.     eval 'print "ok ", $i++, "\n"';
  47. }
  48.  
  49. eval {
  50.     print "ok 14\n";
  51.     die "ok 16\n";
  52.     1;
  53. } || print "ok 15\n$@";
  54.  
  55. # check whether eval EXPR determines value of EXPR correctly
  56.  
  57. {
  58.   my @a = qw(a b c d);
  59.   my @b = eval @a;
  60.   print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
  61.   print $@ ? "not ok 18\n" : "ok 18\n";
  62.  
  63.   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  64.   my $b;
  65.   @a = eval $a;
  66.   print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
  67.   print   $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
  68.   $_ = eval $a;
  69.   print   $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
  70.   eval $a;
  71.   print   $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
  72.  
  73.   $b = 'wrong';
  74.   $x = sub {
  75.      my $b = "right";
  76.      print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
  77.   };
  78.   &$x();
  79. }
  80.  
  81. my $b = 'wrong';
  82. my $X = sub {
  83.    my $b = "right";
  84.    print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
  85. };
  86. &$X();
  87.  
  88.  
  89. # check navigation of multiple eval boundaries to find lexicals
  90.  
  91. my $x = 25;
  92. eval <<'EOT'; die if $@;
  93.   print "# $x\n";    # clone into eval's pad
  94.   sub do_eval1 {
  95.      eval $_[0]; die if $@;
  96.   }
  97. EOT
  98. do_eval1('print "ok $x\n"');
  99. $x++;
  100. do_eval1('eval q[print "ok $x\n"]');
  101. $x++;
  102. do_eval1('sub { eval q[print "ok $x\n"] }->()');
  103. $x++;
  104.  
  105. # calls from within eval'' should clone outer lexicals
  106.  
  107. eval <<'EOT'; die if $@;
  108.   sub do_eval2 {
  109.      eval $_[0]; die if $@;
  110.   }
  111. do_eval2('print "ok $x\n"');
  112. $x++;
  113. do_eval2('eval q[print "ok $x\n"]');
  114. $x++;
  115. do_eval2('sub { eval q[print "ok $x\n"] }->()');
  116. $x++;
  117. EOT
  118.  
  119. # calls outside eval'' should NOT clone lexicals from called context
  120.  
  121. $main::x = 'ok';
  122. eval <<'EOT'; die if $@;
  123.   # $x unbound here
  124.   sub do_eval3 {
  125.      eval $_[0]; die if $@;
  126.   }
  127. EOT
  128. do_eval3('print "$x ' . $x . '\n"');
  129. $x++;
  130. do_eval3('eval q[print "$x ' . $x . '\n"]');
  131. $x++;
  132. do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');
  133. $x++;
  134.  
  135. # can recursive subroutine-call inside eval'' see its own lexicals?
  136. sub recurse {
  137.   my $l = shift;
  138.   if ($l < $x) {
  139.      ++$l;
  140.      eval 'print "# level $l\n"; recurse($l);';
  141.      die if $@;
  142.   }
  143.   else {
  144.     print "ok $l\n";
  145.   }
  146. }
  147. {
  148.   local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
  149.   recurse($x-5);
  150. }
  151. $x++;
  152.  
  153. # do closures created within eval bind correctly?
  154. eval <<'EOT';
  155.   sub create_closure {
  156.     my $self = shift;
  157.     return sub {
  158.        print $self;
  159.     };
  160.   }
  161. EOT
  162. create_closure("ok $x\n")->();
  163. $x++;
  164.  
  165. # does lexical search terminate correctly at subroutine boundary?
  166. $main::r = "ok $x\n";
  167. sub terminal { eval 'print $r' }
  168. {
  169.    my $r = "not ok $x\n";
  170.    eval 'terminal($r)';
  171. }
  172. $x++;
  173.  
  174. # Have we cured panic which occurred with require/eval in die handler ?
  175. $SIG{__DIE__} = sub { eval {1}; die shift }; 
  176. eval { die "ok ".$x++,"\n" }; 
  177. print $@;
  178.  
  179. # does scalar eval"" pop stack correctly?
  180. {
  181.     my $c = eval "(1,2)x10";
  182.     print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
  183.     $x++;
  184. }
  185.  
  186. # return from eval {} should clear $@ correctly
  187. {
  188.     my $status = eval {
  189.     eval { die };
  190.     print "# eval { return } test\n";
  191.     return; # removing this changes behavior
  192.     };
  193.     print "not " if $@;
  194.     print "ok $x\n";
  195.     $x++;
  196. }
  197.  
  198. # ditto for eval ""
  199. {
  200.     my $status = eval q{
  201.     eval q{ die };
  202.     print "# eval q{ return } test\n";
  203.     return; # removing this changes behavior
  204.     };
  205.     print "not " if $@;
  206.     print "ok $x\n";
  207.     $x++;
  208. }
  209.