]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/lib/Variable/Magic/TestValue.pm
Set PERL_DESTRUCT_LEVEL through the environment variable on debugging perls
[perl/modules/Variable-Magic.git] / 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;