t/12-actions.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 * 3 + 2;
   7
   8 use Scope::Context;
   9
  10 {
  11  my $flag;
  12  {
  13   {
  14    my $up = Scope::Context->up;
  15    $up->reap(sub { $flag = -1 });
  16    is $flag, undef, 'reap: not yet 1';
  17    $flag = 1;
  18   }
  19   is $flag, 1, 'reap: not yet 2';
  20   $flag = 2;
  21  }
  22  is $flag, -1, 'reap: done';
  23 }
  24
  25 {
  26  our $x;
  27  {
  28   local $x = 1;
  29   {
  30    local $x = 2;
  31    my $up = Scope::Context->up(2);
  32    $up->localize('$x', -1);
  33    is $x, 2, 'localize: not yet 1';
  34    $x = 3;
  35   }
  36   is $x, 1, 'localize: not yet 2';
  37   $x = 4;
  38  }
  39  is $x, -1, 'localize: done';
  40 }
  41
  42 {
  43  our %h;
  44  {
  45   local $h{x} = 1;
  46   {
  47    local $h{x} = 2;
  48    my $up = Scope::Context->up(2);
  49    $up->localize_elem('%h', 'x', -1);
  50    is $h{x}, 2, 'localize_elem: not yet 1';
  51    $h{x} = 3;
  52   }
  53   is $h{x}, 1, 'localize_elem: not yet 2';
  54   $h{x} = 4;
  55  }
  56  is $h{x}, -1, 'localize_elem: done';
  57 }
  58
  59 {
  60  our %h = (x => 0);
  61  {
  62   local $h{x} = 1;
  63   {
  64    local $h{x} = 2;
  65    my $up = Scope::Context->up(2);
  66    $up->localize_delete('%h', 'x');
  67    is $h{x}, 2, 'localize_delete: not yet 1';
  68    $h{x} = 3;
  69   }
  70   is $h{x}, 1, 'localize_delete: not yet 2';
  71   $h{x} = 4;
  72  }
  73  ok !exists($h{x}), 'localize_delete: done';
  74 }
  75
  76 {
  77  my @res = sub {
  78   sub {
  79    my $up = Scope::Context->sub(1);
  80    $up->unwind(1, 2, 3);
  81    fail 'unwind: not reached 1';
  82   }->();
  83   fail 'unwind: not reached 2';
  84   return qw<x y z t>;
  85  }->();
  86  is_deeply \@res, [ 1, 2, 3 ], 'unwind: done';
  87 }
  88
  89 {
  90  sub outer {
  91   inner(@_);
  92  }
  93  sub inner {
  94   my $up = Scope::Context->sub(1);
  95   my $name = $up->uplevel(
  96    sub { (caller 0)[$_[0]] } => 3
  97   );
  98   is $name, 'main::outer', 'uplevel: done';
  99  }
 100  outer();
 101 }