73 lines
1.6 KiB
Perl
73 lines
1.6 KiB
Perl
package Variable::Magic::TestWatcher;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Test::More;
|
|
|
|
use Carp qw<croak>;
|
|
use Variable::Magic qw<wizard>;
|
|
|
|
use base qw<Exporter>;
|
|
|
|
our @EXPORT = qw<init_watcher watch>;
|
|
|
|
sub _types {
|
|
my $t = shift;
|
|
return { } unless defined $t;
|
|
return {
|
|
'' => sub { +{ $t => 1 } },
|
|
'ARRAY' => sub { my $h = { }; ++$h->{$_} for @$t; $h },
|
|
'HASH' => sub { +{ map { $_ => $t->{$_} } grep $t->{$_}, keys %$t } }
|
|
}->{ref $t}->();
|
|
}
|
|
|
|
our ($wiz, $prefix, %mg);
|
|
|
|
sub init_watcher ($;$) {
|
|
croak 'can\'t initialize twice' if defined $wiz;
|
|
my $types = _types shift;
|
|
$prefix = (defined) ? "$_: " : '' for shift;
|
|
local $@;
|
|
%mg = ();
|
|
$wiz = eval 'wizard ' . join(', ', map {
|
|
"$_ => sub { \$mg{$_}++;" . ($_ eq 'len' ? '$_[2]' : '0') . '}'
|
|
} keys %$types);
|
|
is $@, '', $prefix . 'wizard() doesn\'t croak';
|
|
is_deeply \%mg, { }, $prefix . 'wizard() doesn\'t trigger magic';
|
|
return $wiz;
|
|
}
|
|
|
|
sub watch (&;$$) {
|
|
my $code = shift;
|
|
my $exp = _types shift;
|
|
my $desc = shift;
|
|
my $want = wantarray;
|
|
my @ret;
|
|
local %mg = ();
|
|
local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
|
|
local $@;
|
|
if (not defined $want) { # void context
|
|
eval { $code->() };
|
|
} elsif (not $want) { # scalar context
|
|
$ret[0] = eval { $code->() };
|
|
} else {
|
|
@ret = eval { $code->() };
|
|
}
|
|
is $@, '', $prefix . $desc . ' doesn\'t croak';
|
|
is_deeply \%mg, $exp, $prefix . $desc . ' triggers magic correctly';
|
|
return $want ? @ret : $ret[0];
|
|
}
|
|
|
|
our $mg_end;
|
|
|
|
END {
|
|
if (defined $wiz) {
|
|
undef $wiz;
|
|
$mg_end = { } unless defined $mg_end;
|
|
is_deeply \%mg, $mg_end, $prefix . 'magic triggered at END time';
|
|
}
|
|
}
|
|
|
|
1;
|