t/op/die_unwind.t

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