X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F17-ctl.t;h=ded9d6349d6fe329d8beee693d30cac1bae1d5e2;hb=6e42ee234deb79fad1c91703e5a7ec3bd8bc47f3;hp=e694a16b244f10c997d405a410d1816904d9818c;hpb=25e0ed9971f58639b9f7528c896599a8439988d7;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/t/17-ctl.t b/t/17-ctl.t
index e694a16..ded9d63 100644
--- 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';