t/17-ctl.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 * 8 + 4 * (2 * 6 + 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 1a");
 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 1a");
 164
 165    local $@ = $local_out ? 'xxx' : undef;
 166    eval {
 167     my $x;
 168     local $@ = 'yyy' if $local_in;
 169     cast $x, $wiz;
 170    };
 171    $check->("$desc at eval BLOCK 1b");
 172
 173    local $@ = $local_out ? 'xxx' : undef;
 174    eval q{
 175     my $x;
 176     local $@ = 'yyy' if $local_in;
 177     cast $x, $wiz;
 178    };
 179    $check->("$desc at eval STRING 1b");
 180
 181    local $@ = $local_out ? 'xxx' : undef;
 182    eval {
 183     local $@ = 'yyy' if $local_in;
 184     my $x;
 185     my $y = \$x;
 186     &cast($y, $wiz);
 187    };
 188    $check->("$desc at eval BLOCK 2a");
 189
 190    local $@ = $local_out ? 'xxx' : undef;
 191    eval q{
 192     local $@ = 'yyy' if $local_in;
 193     my $x;
 194     my $y = \$x;
 195     &cast($y, $wiz);
 196    };
 197    $check->("$desc at eval STRING 2a");
 198
 199    local $@ = $local_out ? 'xxx' : undef;
 200    eval {
 201     my $x;
 202     my $y = \$x;
 203     local $@ = 'yyy' if $local_in;
 204     &cast($y, $wiz);
 205    };
 206    $check->("$desc at eval BLOCK 2b");
 207
 208    local $@ = $local_out ? 'xxx' : undef;
 209    eval q{
 210     my $x;
 211     my $y = \$x;
 212     local $@ = 'yyy' if $local_in;
 213     &cast($y, $wiz);
 214    };
 215    $check->("$desc at eval STRING 2b");
 216
 217    local $@ = $local_out ? 'xxx' : undef;
 218    eval {
 219     local $@ = 'yyy' if $local_in;
 220     my $x;
 221     cast $x, $wiz;
 222     my $y = 1;
 223    };
 224    $check->("$desc at eval BLOCK 3");
 225
 226    local $@ = $local_out ? 'xxx' : undef;
 227    eval q{
 228     local $@ = 'yyy' if $local_in;
 229     my $x;
 230     cast $x, $wiz;
 231     my $y = 1;
 232    };
 233    $check->("$desc at eval STRING 3");
 234
 235    local $@ = $local_out ? 'xxx' : undef;
 236    eval {
 237     local $@ = 'yyy' if $local_in;
 238     {
 239      my $x;
 240      cast $x, $wiz;
 241     }
 242    };
 243    $check->("$desc at block in eval BLOCK");
 244
 245    local $@ = $local_out ? 'xxx' : undef;
 246    eval q{
 247     local $@ = 'yyy' if $local_in;
 248     {
 249      my $x;
 250      cast $x, $wiz;
 251     }
 252    };
 253    $check->("$desc at block in eval STRING");
 254
 255    ok defined($desc), "$desc did not over-unwind the save stack";
 256   }
 257  }
 258 }
 259
 260 my $wiz;
 261
 262 eval {
 263  $wiz = wizard data => sub { $_[1] },
 264                free => sub { $_[1]->(); () };
 265  my $x;
 266  cast $x, $wiz, sub { die "spinach" };
 267 };
 268
 269 like $@, expect('spinach', $0), 'die in sub in free callback';
 270
 271 eval {
 272  $wiz = wizard free => sub { die 'zucchini' };
 273  $@ = "";
 274  {
 275   my $x;
 276   cast $x, $wiz;
 277  }
 278  die 'not reached';
 279 };
 280
 281 like $@, expect('zucchini', $0),
 282                           'die in free callback in block in eval with $@ unset';
 283
 284 eval {
 285  $wiz = wizard free => sub { die 'eggplant' };
 286  $@ = "artichoke";
 287  {
 288   my $x;
 289   cast $x, $wiz;
 290  }
 291  die 'not reached again';
 292 };
 293
 294 like $@, expect('eggplant', $0),
 295                             'die in free callback in block in eval with $@ set';
 296
 297 eval q{BEGIN {
 298  $wiz = wizard free => sub { die 'onion' };
 299  my $x;
 300  cast $x, $wiz;
 301 }};
 302
 303 like $@, expect('onion', undef, "\nBEGIN.*"), 'die in free callback in BEGIN';
 304
 305 eval q{BEGIN {
 306  $wiz = wizard data => sub { $_[1] },
 307                len  => sub { $_[1]->(); $_[2] },
 308                free => sub { my $x = @{$_[0]}; () };
 309  my @a = (1 .. 5);
 310  cast @a, $wiz, sub { die "pepperoni" };
 311 }};
 312
 313 like $@, expect('pepperoni', undef, "\nBEGIN.*"),
 314                                 'die in free callback in len callback in BEGIN';
 315
 316 # Inspired by B::Hooks::EndOfScope
 317
 318 eval q{BEGIN {
 319  $wiz = wizard data => sub { $_[1] },
 320                free => sub { $_[1]->(); () };
 321  $^H |= 0x020000;
 322  cast %^H, $wiz, sub { die 'cabbage' };
 323 }};
 324
 325 like $@, expect('cabbage'), 'die in free callback at end of scope';
 326
 327 use lib 't/lib';
 328
 329 my $vm_tse_file = 't/lib/Variable/Magic/TestScopeEnd.pm';
 330
 331 eval "use Variable::Magic::TestScopeEnd";
 332 like $@, expect('turnip', $vm_tse_file, "\nBEGIN(?s:.*)"),
 333         'die in BEGIN in require in eval string triggers hints hash destructor';
 334
 335 eval q{BEGIN {
 336  Variable::Magic::TestScopeEnd::hook {
 337   pass 'in hints hash destructor 2';
 338  };
 339  die "tomato";
 340 }};
 341
 342 like $@, expect('tomato', undef, "\nBEGIN.*"),
 343                           'die in BEGIN in eval triggers hints hash destructor';
 344
 345 sub run_perl {
 346  my $code = shift;
 347
 348  my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
 349  local %ENV;
 350  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
 351  $ENV{PATH}       = $PATH       if $^O eq 'cygwin'  and defined $PATH;
 352
 353  system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
 354 }
 355
 356 my $has_capture_tiny = do {
 357  local $@;
 358  eval {
 359   require Capture::Tiny;
 360   Capture::Tiny->VERSION('0.08');
 361  }
 362 };
 363 if ($has_capture_tiny) {
 364  local $@;
 365  my $output = eval {
 366   Capture::Tiny::capture_merged(sub { run_perl <<'  CODE' });
 367 print STDOUT "pants\n";
 368 print STDERR "trousers\n";
 369   CODE
 370  };
 371  unless (defined $output and $output =~ /pants/ and $output =~ /trousers/) {
 372   $has_capture_tiny = 0;
 373  }
 374 }
 375 if ($has_capture_tiny) {
 376  defined and diag "Using Capture::Tiny $_" for $Capture::Tiny::VERSION;
 377 }
 378
 379 SKIP:
 380 {
 381  my $count = 1;
 382
 383  skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny;
 384
 385  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
 386 use Variable::Magic qw<wizard cast>; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } }
 387  CODE
 388  skip 'Test code didn\'t run properly' => $count unless defined $output;
 389  like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"),
 390                   'die in free callback at compile time and not in eval string';
 391  --$count;
 392 }
 393
 394 # Uvar
 395
 396 SKIP:
 397 {
 398  my $count = 1;
 399
 400  skip 'No nice uvar magic for this perl'     => $count unless VMG_UVAR;
 401  skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny;
 402
 403  my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
 404 use Variable::Magic qw<wizard cast>; BEGIN { cast %derp::, wizard fetch => sub { die q[raddish] } } derp::hlagh()
 405  CODE
 406  skip 'Test code didn\'t run properly' => $count unless defined $output;
 407  like $output, expect('raddish', '-e', "\nExecution(?s:.*)"),
 408                'die in free callback at compile time and not in eval string';
 409  --$count;
 410 }