t/51-unwind-multi.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 13 + 3;
   7
   8 use Scope::Upper qw<unwind SCOPE CALLER>;
   9
  10 my ($l1, $l2);
  11
  12 our $x;
  13
  14 sub c {
  15  $x = 3;
  16  sub {
  17   unwind("eval", eval {
  18    do {
  19     for (3, 4, 5) {
  20      1, unwind('from', 'the', 'sub', 'c' => SCOPE $l1);
  21     }
  22    }
  23   } => SCOPE $l2);
  24  }->(2, 3, 4);
  25  return 'in c'
  26 }
  27
  28 sub b {
  29  local $x = 2;
  30  my @c = (1 .. 12, c());
  31  is $x, 3, '$x in b after c()';
  32  return @c, 'in b';
  33 }
  34
  35 sub a {
  36  local $x = 1;
  37  my @b = b();
  38  is $x, 1, '$x in a after b()';
  39  return @b, 'in a';
  40 }
  41
  42 $l1 = 0;
  43 $l2 = 0;
  44 is_deeply [ a() ], [ 1 .. 12, 'in c', 'in b', 'in a' ],
  45           'l1=0, l2=0';
  46
  47 $l1 = 0;
  48 $l2 = 1;
  49 is_deeply [ a() ], [ 1 .. 12, qw<eval from the sub c>, 'in b', 'in a' ],
  50           'l1=0, l2=1';
  51
  52 $l1 = 0;
  53 $l2 = 2;
  54 is_deeply [ a() ], [ qw<eval from the sub c>, 'in a' ],
  55           'l1=0, l2=2';
  56
  57 $l1 = 4;
  58 $l2 = 999;
  59 is_deeply [ a() ], [ 1 .. 12, qw<from the sub c>, 'in b', 'in a' ],
  60           'l1=4, l2=?';
  61
  62 $l1 = 5;
  63 $l2 = 999;
  64 is_deeply [ a() ], [ qw<from the sub c>, 'in a' ],
  65           'l1=5, l2=?';
  66
  67 # Unwinding while unwinding
  68 {
  69  package Scope::Upper::TestGuard;
  70
  71  sub new {
  72   my $class = shift;
  73   bless { cb => $_[0] }, $class;
  74  }
  75
  76  sub DESTROY {
  77   $_[0]->{cb}->()
  78  }
  79 }
  80
  81 {
  82  my $desc = 'unwinding while unwinding';
  83  local $@;
  84
  85  eval {
  86   my @res = sub {
  87    sub {
  88     my $guard = Scope::Upper::TestGuard->new(sub {
  89      my @res = sub {
  90       sub {
  91        unwind @_ => CALLER(1);
  92       }->(@_);
  93       fail "$desc (second): not reached";
  94      }->(qw<a b c>);
  95      is_deeply \@res, [ qw<a b c> ], "$desc (second): correct returned values";
  96     });
  97     unwind @_ => CALLER(1);
  98    }->(@_);
  99    fail "$desc (first): not reached";
 100   }->(qw<y z>);
 101   is_deeply \@res, [ qw<y z> ], "$desc (first): correct returned values";
 102  };
 103  is $@, '', "$desc: did not croak";
 104 }