]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/30-scalar.t
Bump copyright year
[perl/modules/Variable-Magic.git] / t / 30-scalar.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Config qw<%Config>;
7
8 use Test::More tests => (2 * 14 + 2) + 2 * (2 * 8 + 4) + 5 + 1;
9
10 use lib 't/lib';
11 use VPIT::TestHelpers;
12
13 use Variable::Magic qw<wizard cast dispell>;
14
15 use lib 't/lib';
16 use Variable::Magic::TestWatcher;
17
18 my $is_5130_release = ("$]" == 5.013 && !$Config{git_describe}) ? 1 : 0;
19
20 my $wiz = init_watcher
21         [ qw<get set len clear free copy dup local fetch store exists delete> ],
22         'scalar';
23
24 my $n = int rand 1000;
25 my $a = $n;
26
27 watch { cast $a, $wiz } { }, 'cast';
28
29 my $b;
30 # $b has to be set inside the block for the test to pass on 5.8.3 and lower
31 watch { $b = $a } { get => 1 }, 'assign to';
32 is $b, $n, 'scalar: assign to correctly';
33
34 $b = watch { "X${a}Y" } { get => 1 }, 'interpolate';
35 is $b, "X${n}Y", 'scalar: interpolate correctly';
36
37 $b = watch { \$a } { }, 'reference';
38
39 watch { $a = 123 } { set => 1 }, 'assign to';
40
41 watch { ++$a } { get => 1, set => 1 }, 'increment';
42
43 watch { --$a } { get => 1, set => 1 }, 'decrement';
44
45 watch { $a *= 1.5 } { get => 1, set => 1 }, 'multiply in place';
46
47 watch { $a /= 1.5 } { get => 1, set => 1 }, 'divide in place';
48
49 watch {
50  my $b = $n;
51  watch { cast $b, $wiz } { }, 'cast 2';
52 } { free => 1 }, 'scope end';
53
54 watch { undef $a } { set => 1 }, 'undef';
55
56 watch { dispell $a, $wiz } { }, 'dispell';
57
58 # Array element
59
60 my @a = (7, 8, 9);
61
62 watch { cast $a[1], $wiz } { }, 'array element: cast';
63
64 watch { $a[1] = 6 } { set => 1 }, 'array element: set';
65
66 $b = watch { $a[1] } { get => ($is_5130_release ? 2 : 1) },'array element: get';
67 is $b, 6, 'scalar: array element: get correctly';
68
69 watch { $a[0] = 5 } { }, 'array element: set other';
70
71 $b = watch { $a[2] } { }, 'array element: get other';
72 is $b, 9, 'scalar: array element: get other correctly';
73
74 $b = watch { exists $a[1] } { }, 'array element: exists';
75 is $b, 1, 'scalar: array element: exists correctly';
76
77 # $b has to be set inside the block for the test to pass on 5.8.3 and lower
78 watch { $b = delete $a[1] } { get => 1, free => ("$]" > 5.008_005 ? 1 : 0) },
79                             'array element: delete';
80 is $b, 6, 'scalar: array element: delete correctly';
81
82 watch { $a[1] = 4 } { }, 'array element: set after delete';
83
84 # Hash element
85
86 my %h = (a => 7, b => 8);
87
88 watch { cast $h{b}, $wiz } { }, 'hash element: cast';
89
90 watch { $h{b} = 6 } { set => 1 }, 'hash element: set';
91
92 $b = watch { $h{b} } { get => ($is_5130_release ? 2 : 1) }, 'hash element: get';
93 is $b, 6, 'scalar: hash element: get correctly';
94
95 watch { $h{a} = 5 } { }, 'hash element: set other';
96
97 $b = watch { $h{a} } { }, 'hash element: get other';
98 is $b, 5, 'scalar: hash element: get other correctly';
99
100 $b = watch { exists $h{b} } { }, 'hash element: exists';
101 is $b, 1, 'scalar: hash element: exists correctly';
102
103 $b = watch { delete $h{b} } { get => 1, free => 1 }, 'hash element: delete';
104 is $b, 6, 'scalar: hash element: delete correctly';
105
106 watch { $h{b} = 4 } { }, 'hash element: set after delete';
107
108 SKIP: {
109  load_or_skip('Tie::Array', undef, undef, 5);
110
111  tie my @a, 'Tie::StdArray';
112  $a[0] = $$;
113  $a[1] = -$$;
114
115  eval {
116   cast @a, wizard copy => sub { cast $_[3], $wiz; () };
117  };
118  is $@, '', 'cast copy magic on tied array';
119
120  watch { delete $a[0] } [ qw<clear free> ],
121                         'delete from tied array in void context';
122
123  $b = watch { delete $a[1] } [ qw<get clear free> ],
124                              'delete from tied array in scalar context';
125 }