A better fix for handling exceptions at compile time.

[perl/modules/Variable-Magic.git] / t / 17-ctl.t

diff --git a/t/17-ctl.t b/t/17-ctl.t
index e694a16b244f10c997d405a410d1816904d9818c..ded9d6349d6fe329d8beee693d30cac1bae1d5e2 100644 (file)
--- a/t/17-ctl.t
+++ b/t/17-ctl.t
@@ -3,20 +3,74 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 7;
 
-use Variable::Magic qw/wizard cast getdata/;
+use Variable::Magic qw/wizard cast/;
+
+my $wiz;
+
+eval {
+ $wiz = wizard data => sub { $_[1]->() };
+ my $x;
+ cast $x, $wiz, sub { die "carrot" };
+};
+
+like $@, qr/carrot/, 'die in data callback';
+
+eval {
+ $wiz = wizard data => sub { $_[1] },
+               set  => sub { $_[1]->(); () };
+ my $x;
+ cast $x, $wiz, sub { die "lettuce" };
+ $x = 5;
+};
+
+like $@, qr/lettuce/, 'die in set callback';
+
+my $res = eval {
+ $wiz = wizard data => sub { $_[1] },
+               len  => sub { $_[1]->(); () };
+ my @a = (1 .. 3);
+ cast @a, $wiz, sub { die "potato" };
+ @a;
+};
+
+like $@, qr/potato/, 'die in len callback';
+
+eval {
+ $wiz = wizard data => sub { $_[1] },
+               free => sub { $_[1]->(); () };
+ my $x;
+ cast $x, $wiz, sub { die "spinach" };
+};
+
+like $@, qr/spinach/, 'die in free callback';
 
 # Inspired by B::Hooks::EndOfScope
-# This test is better be left at the beginning of the file, since problems
-# happen at UNITCHECK time
 
-my $wiz;
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1]->() };
+ my $x;
+ cast $x, $wiz, sub { die "pumpkin" };
+}};
 
-BEGIN {
- $wiz = wizard data => sub { $_[1] }, free => sub { $_[1]->(); () };
+like $@, qr/pumpkin/, 'die in data callback in BEGIN';
+
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1] },
+               free => sub { $_[1]->(); () };
  $^H |= 0x020000;
- cast %^H, $wiz, sub { die "harmless" };
-}
+ cast %^H, $wiz, sub { die "macaroni" };
+}};
+
+like $@, qr/macaroni/, 'die in free callback in BEGIN';
+
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1] },
+               len  => sub { $_[1]->(); $_[2] },
+               free => sub { my $x = @{$_[0]}; () };
+ my @a = (1 .. 5);
+ cast @a, $wiz, sub { die "pepperoni" };
+}};
 
-pass 'die in free callback in BEGIN didn\'t segfault';
+like $@, qr/pepperoni/, 'die in len callback in BEGIN';