t/lib/Variable/Magic/TestValue.pm

   1 package Variable::Magic::TestValue;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use Variable::Magic qw<wizard cast>;
   9
  10 use base qw<Exporter>;
  11
  12 our @EXPORT = qw<init_value value>;
  13
  14 our ($exp, $prefix, $desc);
  15
  16 sub value_cb {
  17  my $data = $_[1];
  18  return if $data->{guard};
  19  local $data->{guard} = 1;
  20  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 3;
  21  is_deeply $_[0], $exp, $desc;
  22  ()
  23 }
  24
  25 sub init_value (\[$@%&*]$;$) {
  26  my $type = $_[1];
  27  $prefix  = (defined) ? "$_: " : '' for $_[2];
  28  my $wiz  = eval "wizard data => sub { +{ guard => 0 } }, $type => \\&value_cb";
  29  is $@, '', $prefix . 'wizard() doesn\'t croak';
  30  eval { &cast($_[0], $wiz, $prefix) };
  31  is $@, '', $prefix . 'cast() doesn\'t croak';
  32  return $wiz;
  33 }
  34
  35 sub value (&$;$) {
  36  my ($code, $_exp, $_desc) = @_;
  37  my $want = wantarray;
  38  $_desc = 'value' unless defined $desc;
  39  $_desc = $prefix . $_desc;
  40  my @ret;
  41  {
  42   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
  43   local $exp  = $_exp;
  44   local $desc = $_desc;
  45   if (defined $want and not $want) { # scalar context
  46    $ret[0] = eval { $code->() };
  47   } else {
  48    @ret = eval { $code->() };
  49   }
  50   is $@, '', $desc . ' doesn\'t croak';
  51  }
  52  return $want ? @ret : $ret[0];
  53 }
  54
  55 1;