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;