]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/lib/Variable/Magic/TestWatcher.pm
Set PERL_DESTRUCT_LEVEL through the environment variable on debugging perls
[perl/modules/Variable-Magic.git] / t / lib / Variable / Magic / TestWatcher.pm
1 package Variable::Magic::TestWatcher;
2
3 use strict;
4 use warnings;
5
6 use Test::More;
7
8 use Carp qw<croak>;
9 use Variable::Magic qw<wizard>;
10
11 use base qw<Exporter>;
12
13 our @EXPORT = qw<init_watcher watch>;
14
15 sub _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
25 our ($wiz, $prefix, %mg);
26
27 sub 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
41 sub 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
62 our $mg_end;
63
64 END {
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
72 1;