t/op/die_unwind.t

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