t/75-uid-uplevel.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 2 * 32 + 2 * 21;
   7
   8 use Scope::Upper qw<uplevel uid validate_uid UP>;
   9
  10 for my $run (1, 2) {
  11  sub {
  12   my $above_uid = uid;
  13   my $there     = "in the sub above the target (run $run)";
  14
  15   my $uplevel_uid = sub {
  16    my $target_uid = uid;
  17    my $there      = "in the target sub (run $run)";
  18
  19    my $uplevel_uid = sub {
  20     my $between_uid = uid;
  21     my $there       = "in the sub between the target and the source (run $run)";
  22
  23     my $uplevel_uid = sub {
  24      my $source_uid = uid;
  25      my $there      = "in the source sub (run $run)";
  26
  27      my $uplevel_uid = uplevel {
  28       my $uplevel_uid = uid;
  29       my $there       = "in the uplevel callback (run $run)";
  30       my $invalid     = 'temporarily invalid';
  31
  32       ok  validate_uid($uplevel_uid), "\$uplevel_uid is valid $there";
  33       ok !validate_uid($source_uid),  "\$source_uid is $invalid $there";
  34       ok !validate_uid($between_uid), "\$between_uid is $invalid $there";
  35       ok !validate_uid($target_uid),  "\$target_uid is $invalid $there";
  36       ok  validate_uid($above_uid),   "\$above_uid is valid $there";
  37
  38       isnt $uplevel_uid, $source_uid,  "\$uplevel_uid != \$source_uid $there";
  39       isnt $uplevel_uid, $between_uid, "\$uplevel_uid != \$between_uid $there";
  40       isnt $uplevel_uid, $target_uid,  "\$uplevel_uid != \$target_uid $there";
  41       isnt $uplevel_uid, $above_uid,   "\$uplevel_uid != \$above_uid $there";
  42
  43       {
  44        my $here = uid;
  45
  46        isnt $here, $source_uid,  "\$here != \$source_uid in block $there";
  47        isnt $here, $between_uid, "\$here != \$between_uid in block $there";
  48        isnt $here, $target_uid,  "\$here != \$target_uid in block $there";
  49        isnt $here, $above_uid,   "\$here != \$above_uid in block $there";
  50       }
  51
  52       is uid(UP), $above_uid, "uid(UP) == \$above_uid $there";
  53
  54       return $uplevel_uid;
  55      } UP UP;
  56
  57      ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
  58      ok  validate_uid($source_uid),  "\$source_uid is valid again $there";
  59      ok  validate_uid($between_uid), "\$between_uid is valid again $there";
  60      ok  validate_uid($target_uid),  "\$target_uid is valid again $there";
  61      ok  validate_uid($above_uid),   "\$above_uid is still valid $there";
  62
  63      return $uplevel_uid;
  64     }->();
  65
  66     ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
  67     ok  validate_uid($between_uid), "\$between_uid is valid again $there";
  68     ok  validate_uid($target_uid),  "\$target_uid is valid again $there";
  69     ok  validate_uid($above_uid),   "\$above_uid is still valid $there";
  70
  71     return $uplevel_uid;
  72    }->();
  73
  74    ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
  75    ok  validate_uid($target_uid),  "\$target_uid is valid again $there";
  76    ok  validate_uid($above_uid),   "\$above_uid is still valid $there";
  77
  78    return $uplevel_uid;
  79   }->();
  80
  81   ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
  82   ok  validate_uid($above_uid),   "\$above_uid is still valid $there";
  83
  84   sub {
  85    my $here  = uid;
  86    my $there = "in a new sub at replacing the target";
  87
  88    ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
  89    ok  validate_uid($above_uid),   "\$above_uid is still valid $there";
  90
  91    isnt $here, $uplevel_uid, "\$here != \$uplevel_uid $there";
  92
  93    is   uid(UP), $above_uid, "uid(UP) == \$above_uid $there";
  94   }->();
  95  }->();
  96 }
  97
  98 for my $run (1, 2) {
  99  sub {
 100   my $first_sub = uid;
 101   my $there     = "in the first sub (run $run)";
 102   my $invalid   = 'temporarily invalid';
 103
 104   uplevel {
 105    my $first_uplevel = uid;
 106    my $there         = "in the first uplevel (run $run)";
 107
 108    ok !validate_uid($first_sub),     "\$first_sub is $invalid $there";
 109    ok  validate_uid($first_uplevel), "\$first_uplevel is valid $there";
 110
 111    isnt $first_uplevel, $first_sub, "\$first_uplevel != \$first_sub $there";
 112    isnt uid(UP),        $first_sub, "uid(UP) != \$first_sub $there";
 113
 114    my ($second_sub, $second_uplevel) = sub {
 115     my $second_sub = uid;
 116     my $there      = "in the second sub (run $run)";
 117
 118     my $second_uplevel = uplevel {
 119      my $second_uplevel = uid;
 120      my $there          = "in the second uplevel (run $run)";
 121
 122      ok !validate_uid($first_sub),      "\$first_sub is $invalid $there";
 123      ok  validate_uid($first_uplevel),  "\$first_uplevel is valid $there";
 124      ok !validate_uid($second_sub),     "\$second_sub is $invalid $there";
 125      ok  validate_uid($second_uplevel), "\$second_uplevel is valid $there";
 126
 127      isnt $second_uplevel, $second_sub,
 128                                       "\$second_uplevel != \$second_sub $there";
 129      is   uid(UP),         $first_uplevel,  "uid(UP) == \$first_uplevel $there";
 130
 131      return $second_uplevel;
 132     };
 133
 134     return $second_sub, $second_uplevel;
 135    }->();
 136
 137    ok  validate_uid($first_uplevel),    "\$first_uplevel is still valid $there";
 138    ok !validate_uid($second_sub),      "\$second_sub is no longer valid $there";
 139    ok !validate_uid($second_uplevel),
 140                                    "\$second_uplevel is no longer valid $there";
 141
 142    uplevel {
 143     my $third_uplevel = uid;
 144     my $there         = "in the third uplevel (run $run)";
 145
 146     ok !validate_uid($first_uplevel),      "\$first_uplevel is $invalid $there";
 147     ok !validate_uid($second_sub),     "\$second_sub is no longer valid $there";
 148     ok !validate_uid($second_uplevel),
 149                                    "\$second_uplevel is no longer valid $there";
 150     ok  validate_uid($third_uplevel),         "\$third_uplevel is valid $there";
 151
 152     isnt $third_uplevel, $first_uplevel,
 153                                     "\$third_uplevel != \$first_uplevel $there";
 154     isnt $third_uplevel, $second_sub,  "\$third_uplevel != \$second_sub $there";
 155     isnt $third_uplevel, $second_uplevel,
 156                                    "\$third_uplevel != \$second_uplevel $there";
 157     isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there";
 158    }
 159   }
 160  }->();
 161 }