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