t/op/die_unwind.t

   1 #!./perl -w
   2
   3 chdir 't' if -d 't';
   4 require './test.pl';
   5 use strict;
   6
   7 #
   8 # This test checks for $@ being set early during an exceptional
   9 # unwinding, and that this early setting does not affect the late
  10 # setting used to emit the exception from eval{}.  The early setting is
  11 # a backward-compatibility hack to satisfy modules that were relying on
  12 # the historical early setting in order to detect exceptional unwinding.
  13 # This hack should be removed when a proper way to detect exceptional
  14 # unwinding has been developed.
  15 #
  16
  17 {
  18     package End;
  19     sub DESTROY { $_[0]->() }
  20     sub main::end(&) {
  21         my($cleanup) = @_;
  22         return bless(sub { $cleanup->() }, "End");
  23     }
  24 }
  25
  26 my($uerr, $val, $err);
  27
  28 $@ = "";
  29 $val = eval {
  30         my $c = end { $uerr = $@; $@ = "t2\n"; };
  31         1;
  32 }; $err = $@;
  33 is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block");
  34 is($val, 1, "successful return from 'eval' block");
  35 is($err, "", "\$@ still false after 'end' block inside 'eval' block");
  36
  37 $@ = "t0\n";
  38 $val = eval {
  39         $@ = "t1\n";
  40         my $c = end { $uerr = $@; $@ = "t2\n"; };
  41         1;
  42 }; $err = $@;
  43 is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block");
  44 is($val, 1, "successful return from 'eval' block");
  45 is($err, "", "\$@ still false after 'end' block inside 'eval' block");
  46
  47 $@ = "";
  48 $val = eval {
  49         my $c = end { $uerr = $@; $@ = "t2\n"; };
  50         do {
  51                 die "t3\n";
  52         };
  53         1;
  54 }; $err = $@;
  55 is($uerr, "t3\n");
  56 is($val, undef, "undefined return value from 'eval' block with 'die'");
  57 is($err, "t3\n");
  58
  59 $@ = "t0\n";
  60 $val = eval {
  61         $@ = "t1\n";
  62         my $c = end { $uerr = $@; $@ = "t2\n"; };
  63         do {
  64                 die "t3\n";
  65         };
  66         1;
  67 }; $err = $@;
  68 is($uerr, "t3\n");
  69 is($val, undef, "undefined return value from 'eval' block with 'die'");
  70 is($err, "t3\n");
  71
  72 done_testing();