1package Variable::Magic::TestWatcher; 2 3use strict; 4use warnings; 5 6use Test::More; 7 8use Carp qw<croak>; 9use Variable::Magic qw<wizard>; 10 11use base qw<Exporter>; 12 13our @EXPORT = qw<init_watcher watch>; 14 15sub _types { 16 my $t = shift; 17 return { } unless defined $t; 18 return { 19 '' => sub { +{ $t => 1 } }, 20 'ARRAY' => sub { my $h = { }; ++$h->{$_} for @$t; $h }, 21 'HASH' => sub { +{ map { $_ => $t->{$_} } grep $t->{$_}, keys %$t } } 22 }->{ref $t}->(); 23} 24 25our ($wiz, $prefix, %mg); 26 27sub init_watcher ($;$) { 28 croak 'can\'t initialize twice' if defined $wiz; 29 my $types = _types shift; 30 $prefix = (defined) ? "$_: " : '' for shift; 31 local $@; 32 %mg = (); 33 $wiz = eval 'wizard ' . join(', ', map { 34 "$_ => sub { \$mg{$_}++;" . ($_ eq 'len' ? '$_[2]' : '0') . '}' 35 } keys %$types); 36 is $@, '', $prefix . 'wizard() doesn\'t croak'; 37 is_deeply \%mg, { }, $prefix . 'wizard() doesn\'t trigger magic'; 38 return $wiz; 39} 40 41sub watch (&;$$) { 42 my $code = shift; 43 my $exp = _types shift; 44 my $desc = shift; 45 my $want = wantarray; 46 my @ret; 47 local %mg = (); 48 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; 49 local $@; 50 if (not defined $want) { # void context 51 eval { $code->() }; 52 } elsif (not $want) { # scalar context 53 $ret[0] = eval { $code->() }; 54 } else { 55 @ret = eval { $code->() }; 56 } 57 is $@, '', $prefix . $desc . ' doesn\'t croak'; 58 is_deeply \%mg, $exp, $prefix . $desc . ' triggers magic correctly'; 59 return $want ? @ret : $ret[0]; 60} 61 62our $mg_end; 63 64END { 65 if (defined $wiz) { 66 undef $wiz; 67 $mg_end = { } unless defined $mg_end; 68 is_deeply \%mg, $mg_end, $prefix . 'magic triggered at END time'; 69 } 70} 71 721; 73