]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/22-len.t
Represent nulled COPs as B::COP objects
[perl/modules/Variable-Magic.git] / t / 22-len.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 39 + (2 * 2 + 1) + (5 + 2 * 3);
7
8 use Variable::Magic qw<
9  wizard cast dispell
10  VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_COMPAT_SCALAR_NOLEN
11 >;
12
13 use lib 't/lib';
14 use Variable::Magic::TestValue;
15
16 my $c = 0;
17
18 my $n = 1 + int rand 1000;
19 my $d;
20 my $wiz = wizard len => sub { $d = $_[2]; ++$c; return $n };
21 is $c, 0, 'len: wizard() doesn\'t trigger magic';
22
23 my @a = qw<a b c>;
24
25 $c = 0;
26 cast @a, $wiz;
27 is $c, 0, 'len: cast on array doesn\'t trigger magic';
28
29 $c = 0;
30 $d = undef;
31 my $b = scalar @a;
32 is $c, 1,  'len: get array length triggers magic correctly';
33 is $d, 3,  'len: get array length have correct default length';
34 is $b, $n, 'len: get array length correctly';
35
36 $c = 0;
37 $d = undef;
38 $b = $#a;
39 is $c, 1,      'len: get last array index triggers magic correctly';
40 is $d, 3,      'len: get last array index have correct default length';
41 is $b, $n - 1, 'len: get last array index correctly';
42
43 $n = 0;
44
45 $c = 0;
46 $d = undef;
47 $b = scalar @a;
48 is $c, 1, 'len: get array length 0 triggers magic correctly';
49 is $d, 3, 'len: get array length 0 have correct default length';
50 is $b, 0, 'len: get array length 0 correctly';
51
52 $n = undef;
53 @a = ();
54 cast @a, $wiz;
55
56 $c = 0;
57 $d = undef;
58 $b = scalar @a;
59 is $c, 1, 'len: get empty array length triggers magic correctly';
60 is $d, 0, 'len: get empty array length have correct default length';
61 is $b, 0, 'len: get empty array length correctly';
62
63 $c = 0;
64 $d = undef;
65 $b = $#a;
66 is $c, 1,  'len: get last empty array index triggers magic correctly';
67 is $d, 0,  'len: get last empty array index have correct default length';
68 is $b, -1, 'len: get last empty array index correctly';
69
70 SKIP: {
71  skip 'len magic is no longer called for scalars' => 16 + 6
72                                                      if VMG_COMPAT_SCALAR_NOLEN;
73
74  SKIP: {
75   skip 'length() no longer calls len magic on plain scalars' => 16
76                                               if VMG_COMPAT_SCALAR_LENGTH_NOLEN;
77
78   $c = 0;
79   $n = 1 + int rand 1000;
80   # length magic on scalars needs also get magic to be triggered.
81   my $wiz = wizard get => sub { return 'anything' },
82                    len => sub { $d = $_[2]; ++$c; return $n };
83
84   my $x = 6789;
85
86   $c = 0;
87   cast $x, $wiz;
88   is $c, 0, 'len: cast on scalar doesn\'t trigger magic';
89
90   $c = 0;
91   $d = undef;
92   $b = length $x;
93   is $c, 1,  'len: get scalar length triggers magic correctly';
94   is $d, 4,  'len: get scalar length have correct default length';
95   is $b, $n, 'len: get scalar length correctly';
96
97   $n = 0;
98
99   $c = 0;
100   $d = undef;
101   $b = length $x;
102   is $c, 1,  'len: get scalar length 0 triggers magic correctly';
103   is $d, 4,  'len: get scalar length 0 have correct default length';
104   is $b, $n, 'len: get scalar length 0 correctly';
105
106   $n = undef;
107   $x = '';
108   cast $x, $wiz;
109
110   $c = 0;
111   $d = undef;
112   $b = length $x;
113   is $c, 1, 'len: get empty scalar length triggers magic correctly';
114   is $d, 0, 'len: get empty scalar length have correct default length';
115   is $b, 0, 'len: get empty scalar length correctly';
116
117   $x = "\x{20AB}ongs";
118   cast $x, $wiz;
119
120   {
121    use bytes;
122
123    $c = 0;
124    $d = undef;
125    $b = length $x;
126    is $c, 1, 'len: get utf8 scalar length in bytes triggers magic correctly';
127    is $d, 7, 'len: get utf8 scalar length in bytes have correct default length';
128    is $b, $d,'len: get utf8 scalar length in bytes correctly';
129   }
130
131   $c = 0;
132   $d = undef;
133   $b = length $x;
134   is $c, 1,  'len: get utf8 scalar length triggers magic correctly';
135   is $d, 5,  'len: get utf8 scalar length have correct default length';
136   is $b, $d, 'len: get utf8 scalar length correctly';
137  }
138
139  {
140   our $c;
141   # length magic on scalars needs also get magic to be triggered.
142   my $wiz = wizard get => sub { 0 },
143                    len => sub { $d = $_[2]; ++$c; return $_[2] };
144
145   {
146    my $x = "banana";
147    cast $x, $wiz;
148
149    local $c = 0;
150    pos($x) = 2;
151    is $c, 1,        'len: pos scalar triggers magic correctly';
152    is $d, 6,        'len: pos scalar have correct default length';
153    is $x, 'banana', 'len: pos scalar works correctly'
154   }
155
156   {
157    my $x = "hl\x{20AB}gh"; # Force utf8 on string
158    cast $x, $wiz;
159
160    local $c = 0;
161    substr($x, 2, 1) = 'a';
162    is $c, 1,       'len: substr utf8 scalar triggers magic correctly';
163    is $d, 5,       'len: substr utf8 scalar have correct default length';
164    is $x, 'hlagh', 'len: substr utf8 scalar correctly';
165   }
166  }
167 }
168
169 {
170  my @val = (4 .. 6);
171
172  my $wv = init_value @val, 'len', 'len';
173
174  value { $val[-1] = 8 } [ 4, 5, 6 ];
175
176  dispell @val, $wv;
177  is_deeply \@val, [ 4, 5, 8 ], 'len: after value';
178 }
179
180 {
181  local $@;
182
183  my $wua = eval { wizard len => \undef };
184  is $@, '', 'len: noop wizard (for arrays) creation does not croak';
185
186  my @a = ('a' .. 'z');
187  eval { cast @a, $wua };
188  is $@, '', 'len: noop wizard (for arrays) cast does not croak';
189
190  my $l;
191  eval { $l = $#a };
192  is $@, '', 'len: noop wizard (for arrays) invocation does not croak';
193  is $l, 25, 'len: noop magic on an array returns the previous length';
194
195  my $wus = eval { wizard get => \undef, len => \undef };
196  is $@, '', 'len: noop wizard (for strings) creation does not croak';
197
198  for ([ 'euro', 'string' ], [ "\x{20AC}uro", 'unicode string' ]) {
199   my ($euro, $desc) = @$_;
200
201   eval { cast $euro, $wus };
202   is $@, '', 'len: noop wizard (for strings) cast does not croak';
203
204   eval { pos($euro) = 2 };
205   is $@, '', 'len: noop wizard (for strings) invocation does not croak';
206
207   my ($rest) = ($euro =~ /(.*)/g);
208   is $rest, 'ro', "len: noop magic on a $desc returns the previous length";
209  }
210 }