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