1#!perl -T
2
3use strict;
4use warnings;
5
6use Test::More tests => 39 + (2 * 2 + 1);
7
8use Variable::Magic qw/wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN/;
9
10use lib 't/lib';
11use Variable::Magic::TestValue;
12
13my $c = 0;
14
15my $n = 1 + int rand 1000;
16my $d;
17my $wiz = wizard len => sub { $d = $_[2]; ++$c; return $n };
18is $c, 0, 'len: wizard() doesn\'t trigger magic';
19
20my @a = qw/a b c/;
21
22$c = 0;
23cast @a, $wiz;
24is $c, 0, 'len: cast on array doesn\'t trigger magic';
25
26$c = 0;
27$d = undef;
28my $b = scalar @a;
29is $c, 1,  'len: get array length triggers magic correctly';
30is $d, 3,  'len: get array length have correct default length';
31is $b, $n, 'len: get array length correctly';
32
33$c = 0;
34$d = undef;
35$b = $#a;
36is $c, 1,      'len: get last array index triggers magic correctly';
37is $d, 3,      'len: get last array index have correct default length';
38is $b, $n - 1, 'len: get last array index correctly';
39
40$n = 0;
41
42$c = 0;
43$d = undef;
44$b = scalar @a;
45is $c, 1, 'len: get array length 0 triggers magic correctly';
46is $d, 3, 'len: get array length 0 have correct default length';
47is $b, 0, 'len: get array length 0 correctly';
48
49$n = undef;
50@a = ();
51cast @a, $wiz;
52
53$c = 0;
54$d = undef;
55$b = scalar @a;
56is $c, 1, 'len: get empty array length triggers magic correctly';
57is $d, 0, 'len: get empty array length have correct default length';
58is $b, 0, 'len: get empty array length correctly';
59
60$c = 0;
61$d = undef;
62$b = $#a;
63is $c, 1,  'len: get last empty array index triggers magic correctly';
64is $d, 0,  'len: get last empty array index have correct default length';
65is $b, -1, 'len: get last empty array index correctly';
66
67SKIP: {
68 skip 'length() no longer calls mg_len magic' => 16 if VMG_COMPAT_SCALAR_LENGTH_NOLEN;
69
70 $c = 0;
71 $n = 1 + int rand 1000;
72 # length magic on scalars needs also get magic to be triggered.
73 $wiz = wizard get => sub { return 'anything' },
74               len => sub { $d = $_[2]; ++$c; return $n };
75
76 my $x = 6789;
77
78 $c = 0;
79 cast $x, $wiz;
80 is $c, 0, 'len: cast on scalar doesn\'t trigger magic';
81
82 $c = 0;
83 $d = undef;
84 $b = length $x;
85 is $c, 1,  'len: get scalar length triggers magic correctly';
86 is $d, 4,  'len: get scalar length have correct default length';
87 is $b, $n, 'len: get scalar length correctly';
88
89 $n = 0;
90
91 $c = 0;
92 $d = undef;
93 $b = length $x;
94 is $c, 1,  'len: get scalar length 0 triggers magic correctly';
95 is $d, 4,  'len: get scalar length 0 have correct default length';
96 is $b, $n, 'len: get scalar length 0 correctly';
97
98 $n = undef;
99 $x = '';
100 cast $x, $wiz;
101
102 $c = 0;
103 $d = undef;
104 $b = length $x;
105 is $c, 1, 'len: get empty scalar length triggers magic correctly';
106 is $d, 0, 'len: get empty scalar length have correct default length';
107 is $b, 0, 'len: get empty scalar length correctly';
108
109 $x = "\x{20AB}ongs";
110 cast $x, $wiz;
111
112 {
113  use bytes;
114
115  $c = 0;
116  $d = undef;
117  $b = length $x;
118  is $c, 1,  'len: get utf8 scalar length in bytes triggers magic correctly';
119  is $d, 7,  'len: get utf8 scalar length in bytes have correct default length';
120  is $b, $d, 'len: get utf8 scalar length in bytes correctly';
121 }
122
123 $c = 0;
124 $d = undef;
125 $b = length $x;
126 is $c, 1,  'len: get utf8 scalar length triggers magic correctly';
127 is $d, 5,  'len: get utf8 scalar length have correct default length';
128 is $b, $d, 'len: get utf8 scalar length correctly';
129}
130
131{
132 our $c;
133 # length magic on scalars needs also get magic to be triggered.
134 my $wiz = wizard get => sub { 0 },
135                  len => sub { $d = $_[2]; ++$c; return $_[2] };
136
137 {
138  my $x = "banana";
139  cast $x, $wiz;
140
141  local $c = 0;
142  pos($x) = 2;
143  is $c, 1,        'len: pos scalar triggers magic correctly';
144  is $d, 6,        'len: pos scalar have correct default length';
145  is $x, 'banana', 'len: pos scalar works correctly'
146 }
147
148 {
149  my $x = "hl\x{20AB}gh"; # Force utf8 on string
150  cast $x, $wiz;
151
152  local $c = 0;
153  substr($x, 2, 1) = 'a';
154  is $c, 1,       'len: substr utf8 scalar triggers magic correctly';
155  is $d, 5,       'len: substr utf8 scalar have correct default length';
156  is $x, 'hlagh', 'len: substr utf8 scalar correctly';
157 }
158}
159
160{
161 my @val = (4 .. 6);
162
163 my $wv = init_value @val, 'len', 'len';
164
165 value { $val[-1] = 8 } [ 4, 5, 6 ];
166
167 dispell @val, $wv;
168 is_deeply \@val, [ 4, 5, 8 ], 'len: after value';
169}
170