]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/28-uvar.t
Convert t/27-local.t to the new testing framework
[perl/modules/Variable-Magic.git] / t / 28-uvar.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More;
7
8 use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
9
10 if (VMG_UVAR) {
11  plan tests => 20;
12 } else {
13  plan skip_all => 'No nice uvar magic for this perl';
14 }
15
16 my @c = (0) x 4;
17 my @x = (0) x 4;
18
19 sub check {
20  is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 3]),
21     join(':', map { (defined) ? $_ : 'u' } @x[0 .. 3]),
22     $_[0];
23 }
24
25 my $wiz = wizard 'fetch'  => sub { ++$c[0] },
26                  'store'  => sub { ++$c[1] },
27                  'exists' => sub { ++$c[2] },
28                  'delete' => sub { ++$c[3] };
29 check('uvar : create wizard');
30
31 my %h = (a => 1, b => 2, c => 3);
32 my $res = cast %h, $wiz;
33 ok($res, 'uvar : cast succeeded');
34 check(   'uvar : cast didn\'t triggered the callback');
35
36 my $x = $h{a};
37 ++$x[0];
38 check( 'uvar : fetch directly');
39 ok($x, 'uvar : fetch directly correctly');
40
41 $x = "$h{b}";
42 ++$x[0];
43 check(    'uvar : fetch by interpolation');
44 is($x, 2, 'uvar : fetch by interpolation correctly');
45
46 $h{c} = 4;
47 ++$x[1];
48 check('uvar : store directly');
49
50 $x = $h{c} = 5;
51 ++$x[1];
52 check(    'uvar : fetch and store');
53 is($x, 5, 'uvar : fetch and store correctly');
54
55 $x = exists $h{c};
56 ++$x[2];
57 check( 'uvar : exists');
58 ok($x, 'uvar : exists correctly');
59
60 $x = delete $h{c};
61 ++$x[3];
62 check(    'uvar : delete existing key');
63 is($x, 5, 'uvar : delete existing key correctly');
64
65 $x = delete $h{z};
66 ++$x[3];
67 check(          'uvar : delete non-existing key');
68 ok(!defined $x, 'uvar : delete non-existing key correctly');
69
70 my $wiz2 = wizard 'fetch'  => sub { 0 };
71 my %h2 = (a => 37, b => 2, c => 3);
72 cast %h2, $wiz2;
73
74 eval {
75  local $SIG{__WARN__} = sub { die };
76  $x = $h2{a};
77 };
78 is($@, '', 'uvar : fetch with incomplete magic');
79 is($x, 37, 'uvar : fetch with incomplete magic correctly');
80
81 eval {
82  local $SIG{__WARN__} = sub { die };
83  $h2{a} = 73;
84 };
85 is($@, '',     'uvar : store with incomplete magic');
86 is($h2{a}, 73, 'uvar : store with incomplete magic correctly');