]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/28-uvar.t
Represent nulled COPs as B::COP objects
[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 lib 't/lib';
9 use VPIT::TestHelpers;
10
11 use Variable::Magic qw<wizard cast dispell VMG_UVAR>;
12
13 if (VMG_UVAR) {
14  plan tests => 2 * 15 + 12 + 14 + (4 * 2 * 2 + 1 + 1) + 1;
15 } else {
16  plan skip_all => 'No nice uvar magic for this perl';
17 }
18
19 use lib 't/lib';
20 use Variable::Magic::TestWatcher;
21 use Variable::Magic::TestValue;
22
23 my $wiz = init_watcher [ qw<fetch store exists delete> ], 'uvar';
24
25 my %h = (a => 1, b => 2, c => 3);
26
27 my $res = watch { cast %h, $wiz } { }, 'cast';
28 ok $res, 'uvar: cast succeeded';
29
30 my $x = watch { $h{a} } { fetch => 1 }, 'fetch directly';
31 is $x, 1, 'uvar: fetch directly correctly';
32
33 $x = watch { "$h{b}" } { fetch => 1 }, 'fetch by interpolation';
34 is $x, 2, 'uvar: fetch by interpolation correctly';
35
36 watch { $h{c} = 4 } { store => 1 }, 'store directly';
37
38 $x = watch { $h{c} = 5 } { store => 1 }, 'fetch and store';
39 is $x, 5, 'uvar: fetch and store correctly';
40
41 $x = watch { exists $h{c} } { exists => 1 }, 'exists';
42 ok $x, 'uvar: exists correctly';
43
44 $x = watch { delete $h{c} } { delete => 1 }, 'delete existing key';
45 is $x, 5, 'uvar: delete existing key correctly';
46
47 $x = watch { delete $h{z} } { delete => 1 }, 'delete non-existing key';
48 ok !defined $x, 'uvar: delete non-existing key correctly';
49
50 my $wiz2 = wizard get => sub { 0 };
51 cast %h, $wiz2;
52
53 $x = watch { $h{a} } { fetch => 1 }, 'fetch directly with also non uvar magic';
54 is $x, 1, 'uvar: fetch directly with also non uvar magic correctly';
55
56 SKIP: {
57  load_or_skip('Tie::Hash', undef, undef, 2 * 5 + 4);
58
59  tie my %h, 'Tie::StdHash';
60  %h = (x => 7, y => 8);
61
62  $res = watch { cast %h, $wiz } { }, 'cast on tied hash';
63  ok $res, 'uvar: cast on tied hash succeeded';
64
65  $x = watch { $h{x} } { fetch => 1 }, 'fetch on tied hash';
66  is $x, 7, 'uvar: fetch on tied hash succeeded';
67
68  watch { $h{x} = 9 } { store => 1 }, 'store on tied hash';
69
70  $x = watch { exists $h{x} } { exists => 1 }, 'exists on tied hash';
71  ok $x, 'uvar: exists on tied hash succeeded';
72
73  $x = watch { delete $h{x} } { delete => 1 }, 'delete on tied hash';
74  is $x, 9, 'uvar: delete on tied hash succeeded';
75 }
76
77 $wiz2 = wizard fetch => sub { 0 };
78 my %h2 = (a => 37, b => 2, c => 3);
79 cast %h2, $wiz2;
80
81 $x = eval {
82  local $SIG{__WARN__} = sub { die };
83  $h2{a};
84 };
85 is $@, '', 'uvar: fetch with incomplete magic doesn\'t croak';
86 is $x, 37, 'uvar: fetch with incomplete magic correctly';
87
88 eval {
89  local $SIG{__WARN__} = sub { die };
90  $h2{a} = 73;
91 };
92 is $@, '',     'uvar: store with incomplete magic doesn\'t croak';
93 is $h2{a}, 73, 'uvar: store with incomplete magic correctly';
94
95 my $wiz3 = wizard store => sub { ++$_[2]; 0 }, copy_key => 1;
96 my %h3 = (a => 3);
97 cast %h3, $wiz3;
98
99 for my $i (1 .. 2) {
100  my $key = 'a';
101  eval { $h3{$key} = 3 + $i };
102  is        $@,   '',  "uvar: change key in store doesn't croak ($i)";
103  is        $key, 'a', "uvar: change key didn't clobber \$key ($i)";
104  is_deeply \%h3, { a => 3, b => 3 + $i },
105                       "uvar: change key in store correcty ($i)";
106 }
107
108 for my $i (1 .. 2) {
109  eval { $h3{b} = 5 + $i };
110  is        $@,   '',    "uvar: change readonly key in store doesn't croak ($i)";
111  is_deeply \%h3, { a => 3, b => 5, c => 5 + $i },
112                         "uvar: change readonly key in store correcty ($i)";
113 }
114
115 {
116  my %val = (apple => 1);
117
118  init_value %val, 'fetch', 'uvar';
119
120  value { my $x = $val{apple} } { apple => 1 }, 'value store';
121 }
122
123 {
124  my %val = (apple => 1);
125
126  my $wv = init_value %val, 'store', 'uvar';
127
128  value { $val{apple} = 2 } { apple => 1 }, 'value store';
129
130  dispell %val, $wv;
131  is_deeply \%val, { apple => 2 }, 'uvar: value after store';
132 }
133
134 {
135  my %val = (apple => 1);
136
137  init_value %val, 'exists', 'uvar';
138
139  value { my $x = exists $val{apple} } { apple => 1 }, 'value exists';
140 }
141
142 {
143  my %val = (apple => 1, banana => 2);
144
145  my $wv = init_value %val, 'delete', 'uvar';
146
147  value { delete $val{apple} } { apple => 1, banana => 2 }, 'value delete';
148
149  dispell %val, $wv;
150  is_deeply \%val, { banana => 2 }, 'uvar: value after delete';
151 }