6 use Test::More tests => 39 + (2 * 2 + 1) + (5 + 2 * 3);
8 use Variable::Magic qw<wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN>;
11 use Variable::Magic::TestValue;
15 my $n = 1 + int rand 1000;
17 my $wiz = wizard len => sub { $d = $_[2]; ++$c; return $n };
18 is $c, 0, 'len: wizard() doesn\'t trigger magic';
24 is $c, 0, 'len: cast on array doesn\'t trigger magic';
29 is $c, 1, 'len: get array length triggers magic correctly';
30 is $d, 3, 'len: get array length have correct default length';
31 is $b, $n, 'len: get array length correctly';
36 is $c, 1, 'len: get last array index triggers magic correctly';
37 is $d, 3, 'len: get last array index have correct default length';
38 is $b, $n - 1, 'len: get last array index correctly';
45 is $c, 1, 'len: get array length 0 triggers magic correctly';
46 is $d, 3, 'len: get array length 0 have correct default length';
47 is $b, 0, 'len: get array length 0 correctly';
56 is $c, 1, 'len: get empty array length triggers magic correctly';
57 is $d, 0, 'len: get empty array length have correct default length';
58 is $b, 0, 'len: get empty array length correctly';
63 is $c, 1, 'len: get last empty array index triggers magic correctly';
64 is $d, 0, 'len: get last empty array index have correct default length';
65 is $b, -1, 'len: get last empty array index correctly';
68 skip 'length() no longer calls mg_len magic' => 16 if VMG_COMPAT_SCALAR_LENGTH_NOLEN;
71 $n = 1 + int rand 1000;
72 # length magic on scalars needs also get magic to be triggered.
73 my $wiz = wizard get => sub { return 'anything' },
74 len => sub { $d = $_[2]; ++$c; return $n };
80 is $c, 0, 'len: cast on scalar doesn\'t trigger magic';
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';
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';
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';
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';
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';
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] };
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'
149 my $x = "hl\x{20AB}gh"; # Force utf8 on string
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';
163 my $wv = init_value @val, 'len', 'len';
165 value { $val[-1] = 8 } [ 4, 5, 6 ];
168 is_deeply \@val, [ 4, 5, 8 ], 'len: after value';
174 my $wua = eval { wizard len => \undef };
175 is $@, '', 'len: noop wizard (for arrays) creation does not croak';
177 my @a = ('a' .. 'z');
178 eval { cast @a, $wua };
179 is $@, '', 'len: noop wizard (for arrays) cast does not croak';
183 is $@, '', 'len: noop wizard (for arrays) invocation does not croak';
184 is $l, 25, 'len: noop magic on an array returns the previous length';
186 my $wus = eval { wizard get => \undef, len => \undef };
187 is $@, '', 'len: noop wizard (for strings) creation does not croak';
189 for ([ 'euro', 'string' ], [ "\x{20AC}uro", 'unicode string' ]) {
190 my ($euro, $desc) = @$_;
192 eval { cast $euro, $wus };
193 is $@, '', 'len: noop wizard (for strings) cast does not croak';
195 eval { pos($euro) = 2 };
196 is $@, '', 'len: noop wizard (for strings) invocation does not croak';
198 my ($rest) = ($euro =~ /(.*)/g);
199 is $rest, 'ro', "len: noop magic on a $desc returns the previous length";