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