t/17-ctl.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 * 8 + 4 * (2 * 4 + 1) + 10 + 1 + 1;
   7
   8 use Variable::Magic qw<wizard cast VMG_UVAR>;
   9
  10 sub expect {
  11  my ($name, $where, $suffix) = @_;
  12  $where  = defined $where ? quotemeta $where : '\(eval \d+\)';
  13  my $end = defined $suffix ? "$suffix\$" : '$';
  14  qr/^\Q$name\E at $where line \d+\.$end/
  15 }
  16
  17 my @scalar_tests = (
  18  [ 'data', sub { \(my $x) },   sub { }                    ],
  19  [ 'get',  sub { \(my $x) },   sub { my $y = ${$_[0]} }   ],
  20  [ 'set',  sub { \(my $x) },   sub { ${$_[0]} = 1 }       ],
  21  [ 'len',  sub { [ 1 .. 3 ] }, sub { my $res = @{$_[0]} } ],
  22 );
  23
  24 # Data, get, set, len
  25
  26 for my $t (@scalar_tests) {
  27  my ($name, $init, $code) = @$t;
  28
  29  my $wiz = wizard $name => sub { die 'leek' };
  30
  31  {
  32   local $@;
  33   eval {
  34    my $x = $init->();
  35    &cast($x, $wiz);
  36    $code->($x);
  37   };
  38   like $@, expect('leek', $0),
  39                             "die in $name callback (direct, \$@ unset) in eval";
  40  }
  41
  42  {
  43   local $@;
  44   eval {
  45    my $x = $init->();
  46    &cast($x, $wiz);
  47    $@ = 'artichoke';
  48    $code->($x);
  49   };
  50   like $@, expect('leek', $0),
  51                               "die in $name callback (direct, \$@ set) in eval";
  52  }
  53
  54  {
  55   local $@;
  56   eval q{BEGIN {
  57    my $x = $init->();
  58    &cast($x, $wiz);
  59    $code->($x);
  60   }};
  61   like $@, expect('leek', $0, "\nBEGIN.*"),
  62                            "die in $name callback (direct, \$@ unset) in BEGIN";
  63  }
  64
  65  {
  66   local $@;
  67   eval q{BEGIN {
  68    my $x = $init->();
  69    &cast($x, $wiz);
  70    $@ = 'artichoke';
  71    $code->($x);
  72   }};
  73   like $@, expect('leek', $0, "\nBEGIN.*"),
  74                              "die in $name callback (direct, \$@ set) in BEGIN";
  75  }
  76
  77  $wiz = wizard(
  78   ($name eq 'data' ? () : (data  => sub { $_[1] })),
  79    $name => sub { $_[1]->(); () },
  80  );
  81
  82  {
  83   local $@;
  84   eval {
  85    my $x = $init->();
  86    &cast($x, $wiz, sub { die 'lettuce' });
  87    $code->($x);
  88   };
  89   like $@, expect('lettuce', $0),
  90                           "die in $name callback (indirect, \$@ unset) in eval";
  91  }
  92
  93  {
  94   local $@;
  95   eval {
  96    my $x = $init->();
  97    &cast($x, $wiz, sub { die 'carrot' });
  98    $@ = 'artichoke';
  99    $code->($x);
 100   };
 101   like $@, expect('carrot', $0),
 102                           "die in $name callback (indirect, \$@ unset) in eval";
 103  }
 104
 105  {
 106   local $@;
 107   eval q{BEGIN {
 108    my $x = $init->();
 109    &cast($x, $wiz, sub { die "pumpkin" });
 110    $code->($x);
 111   }};
 112   like $@, expect('pumpkin', undef, "\nBEGIN.*"),
 113                          "die in $name callback (indirect, \$@ unset) in BEGIN";
 114  }
 115
 116  {
 117   local $@;
 118   eval q{BEGIN {
 119    my $x = $init->();
 120    &cast($x, $wiz, sub { die "chard" });
 121    $@ = 'artichoke';
 122    $code->($x);
 123   }};
 124   like $@, expect('chard', undef, "\nBEGIN.*"),
 125                            "die in $name callback (indirect, \$@ set) in BEGIN";
 126  }
 127 }
 128
 129 # Free
 130
 131 {
 132  my $wiz   = wizard free => sub { die 'avocado' };
 133  my $check = sub { like $@, expect('avocado', $0), $_[0] };
 134
 135  for my $local_out (0, 1) {
 136   for my $local_in (0, 1) {
 137    my $desc   = "die in free callback";
 138    if ($local_in or $local_out) {
 139     $desc .= ' with $@ localized ';
 140     if ($local_in and $local_out) {
 141      $desc .= 'inside and outside';
 142     } elsif ($local_in) {
 143      $desc .= 'inside';
 144     } else {
 145      $desc .= 'outside';
 146     }
 147    }
 148
 149    local $@ = $local_out ? 'xxx' : undef;
 150    eval {
 151     local $@ = 'yyy' if $local_in;
 152     my $x;
 153     cast $x, $wiz;
 154    };
 155    $check->("$desc at eval BLOCK 1");
 156
 157    local $@ = $local_out ? 'xxx' : undef;
 158    eval q{
 159     local $@ = 'yyy' if $local_in;
 160     my $x;
 161     cast $x, $wiz;
 162    };
 163    $check->("$desc at eval STRING 1");
 164
 165    local $@ = $local_out ? 'xxx' : undef;
 166    eval {
 167     local $@ = 'yyy' if $local_in;
 168     my $x;
 169     my $y = \$x;
 170     &cast($y, $wiz);
 171    };
 172    $check->("$desc at eval BLOCK 2");
 173
 174    local $@ = $local_out ? 'xxx' : undef;
 175    eval q{
 176     local $@ = 'yyy' if $local_in;
 177     my $x;
 178     my $y = \$x;
 179     &cast($y, $wiz);
 180    };
 181    $check->("$desc at eval STRING 2");
 182
 183    local $@ = $local_out ? 'xxx' : undef;
 184    eval {
 185     local $@ = 'yyy' if $local_in;
 186     my $x;
 187     cast $x, $wiz;
 188     my $y = 1;
 189    };
 190    $check->("$desc at eval BLOCK 3");
 191
 192    local $@ = $local_out ? 'xxx' : undef;
 193    eval q{
 194     local $@ = 'yyy' if $local_in;
 195     my $x;
 196     cast $x, $wiz;
 197     my $y = 1;
 198    };
 199    $check->("$desc at eval STRING 3");
 200
 201    local $@ = $local_out ? 'xxx' : undef;
 202    eval {
 203     local $@ = 'yyy' if $local_in;
 204     {
 205      my $x;
 206      cast $x, $wiz;
 207     }
 208    };
 209    $check->("$desc at block in eval BLOCK");
 210
 211    local $@ = $local_out ? 'xxx' : undef;
 212    eval q{
 213     local $@ = 'yyy' if $local_in;
 214     {
 215      my $x;
 216      cast $x, $wiz;
 217     }
 218    };
 219    $check->("$desc at block in eval STRING");
 220
 221    ok defined($desc), "$desc did not over-unwind the save stack";
 222   }
 223  }
 224 }
 225
 226 my $wiz;
 227
 228 eval {
 229  $wiz = wizard data => sub { $_[1] },
 230                free => sub { $_[1]->(); () };
 231  my $x;
 232  cast $x, $wiz, sub { die "spinach" };
 233 };
 234
 235 like $@, expect('spinach', $0), 'die in sub in free callback';
 236
 237 eval {
 238  $wiz = wizard free => sub { die 'zucchini' };
 239  $@ = "";
 240  {
 241   my $x;
 242   cast $x, $wiz;
 243  }
 244  die 'not reached';
 245 };
 246
 247 like $@, expect('zucchini', $0),
 248                           'die in free callback in block in eval with $@ unset';
 249
 250 eval {
 251  $wiz = wizard free => sub { die 'eggplant' };
 252  $@ = "artichoke";
 253  {
 254   my $x;
 255   cast $x, $wiz;
 256  }
 257  die 'not reached again';
 258 };
 259
 260 like $@, expect('eggplant', $0),
 261                             'die in free callback in block in eval with $@ set';
 262
 263 eval q{BEGIN {
 264  $wiz = wizard free => sub { die 'onion' };
 265  my $x;
 266  cast $x, $wiz;
 267 }};
 268
 269 like $@, expect('onion', undef, "\nBEGIN.*"), 'die in free callback in BEGIN';
 270
 271 eval q{BEGIN {
 272  $wiz = wizard data => sub { $_[1] },
 273                len  => sub { $_[1]->(); $_[2] },
 274                free => sub { my $x = @{$_[0]}; () };
 275  my @a = (1 .. 5);
 276  cast @a, $wiz, sub { die "pepperoni" };
 277 }};
 278
 279 like $@, expect('pepperoni', undef, "\nBEGIN.*"),
 280                                 'die in free callback in len callback in BEGIN';
 281
 282 # Inspired by B::Hooks::EndOfScope
 283
 284 eval q{BEGIN {
 285  $wiz = wizard data => sub { $_[1] },
 286                free => sub { $_[1]->(); () };
 287  $^H |= 0x020000;
 288  cast %^H, $wiz, sub { die 'cabbage' };
 289 }};
 290
 291 like $@, expect('cabbage'), 'die in free callback at end of scope';
 292
 293 use lib 't/lib';
 294
 295 my $vm_tse_file = 't/lib/Variable/Magic/TestScopeEnd.pm';
 296
 297 eval "use Variable::Magic::TestScopeEnd";
 298 like $@, expect('turnip', $vm_tse_file, "\nBEGIN(?s:.*)"),
 299         'die in BEGIN in require in eval string triggers hints hash destructor';
 300
 301 eval q{BEGIN {
 302  Variable::Magic::TestScopeEnd::hook {
 303   pass 'in hints hash destructor 2';
 304  };
 305  die "tomato";
 306 }};
 307
 308 like $@, expect('tomato', undef, "\nBEGIN.*"),
 309                           'die in BEGIN in eval triggers hints hash destructor';
 310
 311 sub run_perl {
 312  my $code = shift;
 313
 314  my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
 315  local %ENV;
 316  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
 317  $ENV{PATH}       = $PATH       if $^O eq 'cygwin'  and defined $PATH;
 318
 319  system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
 320 }
 321
 322 my $has_capture_tiny = do {
 323  local $@;
 324  eval {
 325   require Capture::Tiny;
 326   Capture::Tiny->VERSION('0.08');
 327  }
 328 };
 329 if ($has_capture_tiny) {
 330  local $@;
 331  my $output = eval {
 332   Capture::Tiny::capture_merged(sub { run_perl <<'  CODE' });
 333 print STDOUT "pants\n";
 334 print STDERR "trousers\n";
 335   CODE
 336  };
 337  unless (defined $output and $output =~ /pants/ and $output =~ /trousers/) {
 338   $has_capture_tiny = 0;
 339  }
 340 }
 341 if ($has_capture_tiny) {
 342  defined and diag "Using Capture::Tiny $_" for $Capture::Tiny::VERSION;
 343 }
 344
 345 SKIP:
 346 {
 347  my $count = 1;
 348
 349  skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny;
 350
 351  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
 352 use Variable::Magic qw<wizard cast>; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } }
 353  CODE
 354  skip 'Test code didn\'t run properly' => $count unless defined $output;
 355  like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"),
 356                   'die in free callback at compile time and not in eval string';
 357  --$count;
 358 }
 359
 360 # Uvar
 361
 362 SKIP:
 363 {
 364  my $count = 1;
 365
 366  skip 'No nice uvar magic for this perl'     => $count unless VMG_UVAR;
 367  skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny;
 368
 369  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
 370 use Variable::Magic qw<wizard cast>; BEGIN { cast %derp::, wizard fetch => sub { die q[raddish] } } derp::hlagh()
 371  CODE
 372  skip 'Test code didn\'t run properly' => $count unless defined $output;
 373  like $output, expect('raddish', '-e', "\nExecution(?s:.*)"),
 374                'die in free callback at compile time and not in eval string';
 375  --$count;
 376 }