]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/22-len.t
Add more glob tests
[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);
7
8 use Variable::Magic qw/wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN/;
9
10 use lib 't/lib';
11 use Variable::Magic::TestValue;
12
13 my $c = 0;
14
15 my $n = 1 + int rand 1000;
16 my $d;
17 my $wiz = wizard len => sub { $d = $_[2]; ++$c; return $n };
18 is $c, 0, 'len: wizard() doesn\'t trigger magic';
19
20 my @a = qw/a b c/;
21
22 $c = 0;
23 cast @a, $wiz;
24 is $c, 0, 'len: cast on array doesn\'t trigger magic';
25
26 $c = 0;
27 $d = undef;
28 my $b = scalar @a;
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';
32
33 $c = 0;
34 $d = undef;
35 $b = $#a;
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';
39
40 $n = 0;
41
42 $c = 0;
43 $d = undef;
44 $b = scalar @a;
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';
48
49 $n = undef;
50 @a = ();
51 cast @a, $wiz;
52
53 $c = 0;
54 $d = undef;
55 $b = scalar @a;
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';
59
60 $c = 0;
61 $d = undef;
62 $b = $#a;
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';
66
67 SKIP: {
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 }