Commit | Line | Data |
---|---|---|
8ebc5c01 | 1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
78cd8b71 | 6 | require Config; |
98641f60 | 7 | if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ |
78cd8b71 NC |
8 | print "1..0 # Skip -- Perl configured without List::Util module\n"; |
9 | exit 0; | |
10 | } | |
8ebc5c01 | 11 | } |
12 | ||
8ebc5c01 | 13 | package Oscalar; |
14 | use overload ( | |
15 | # Anonymous subroutines: | |
16 | '+' => sub {new Oscalar $ {$_[0]}+$_[1]}, | |
17 | '-' => sub {new Oscalar | |
18 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, | |
19 | '<=>' => sub {new Oscalar | |
20 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, | |
21 | 'cmp' => sub {new Oscalar | |
22 | $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, | |
23 | '*' => sub {new Oscalar ${$_[0]}*$_[1]}, | |
24 | '/' => sub {new Oscalar | |
25 | $_[2]? $_[1]/${$_[0]} : | |
26 | ${$_[0]}/$_[1]}, | |
27 | '%' => sub {new Oscalar | |
28 | $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, | |
29 | '**' => sub {new Oscalar | |
30 | $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, | |
31 | ||
32 | qw( | |
33 | "" stringify | |
34 | 0+ numify) # Order of arguments unsignificant | |
35 | ); | |
36 | ||
37 | sub new { | |
38 | my $foo = $_[1]; | |
39 | bless \$foo, $_[0]; | |
40 | } | |
41 | ||
42 | sub stringify { "${$_[0]}" } | |
43 | sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead | |
44 | # comparing to direct compilation based on | |
45 | # stringify | |
46 | ||
47 | package main; | |
48 | ||
446eaa42 | 49 | our $test = 0; |
8ebc5c01 | 50 | $| = 1; |
51 | print "1..",&last,"\n"; | |
52 | ||
53 | sub test { | |
b3ac6de7 IZ |
54 | $test++; |
55 | if (@_ > 1) { | |
61f33854 RGS |
56 | my $comment = ""; |
57 | $comment = " # " . $_ [2] if @_ > 2; | |
b3ac6de7 | 58 | if ($_[0] eq $_[1]) { |
61f33854 | 59 | print "ok $test$comment\n"; |
0bdaccee | 60 | return 1; |
b3ac6de7 | 61 | } else { |
61f33854 RGS |
62 | $comment .= ": '$_[0]' ne '$_[1]'"; |
63 | print "not ok $test$comment\n"; | |
0bdaccee | 64 | return 0; |
b3ac6de7 IZ |
65 | } |
66 | } else { | |
67 | if (shift) { | |
68 | print "ok $test\n"; | |
0bdaccee | 69 | return 1; |
b3ac6de7 IZ |
70 | } else { |
71 | print "not ok $test\n"; | |
0bdaccee NC |
72 | return 0; |
73 | } | |
b3ac6de7 | 74 | } |
8ebc5c01 | 75 | } |
76 | ||
77 | $a = new Oscalar "087"; | |
78 | $b= "$a"; | |
79 | ||
80 | # All test numbers in comments are off by 1. | |
81 | # So much for hard-wiring them in :-) To fix this: | |
82 | test(1); # 1 | |
83 | ||
84 | test ($b eq $a); # 2 | |
85 | test ($b eq "087"); # 3 | |
86 | test (ref $a eq "Oscalar"); # 4 | |
87 | test ($a eq $a); # 5 | |
88 | test ($a eq "087"); # 6 | |
89 | ||
90 | $c = $a + 7; | |
91 | ||
92 | test (ref $c eq "Oscalar"); # 7 | |
93 | test (!($c eq $a)); # 8 | |
94 | test ($c eq "94"); # 9 | |
95 | ||
96 | $b=$a; | |
97 | ||
98 | test (ref $a eq "Oscalar"); # 10 | |
99 | ||
100 | $b++; | |
101 | ||
102 | test (ref $b eq "Oscalar"); # 11 | |
103 | test ( $a eq "087"); # 12 | |
104 | test ( $b eq "88"); # 13 | |
105 | test (ref $a eq "Oscalar"); # 14 | |
106 | ||
107 | $c=$b; | |
108 | $c-=$a; | |
109 | ||
110 | test (ref $c eq "Oscalar"); # 15 | |
111 | test ( $a eq "087"); # 16 | |
112 | test ( $c eq "1"); # 17 | |
113 | test (ref $a eq "Oscalar"); # 18 | |
114 | ||
115 | $b=1; | |
116 | $b+=$a; | |
117 | ||
118 | test (ref $b eq "Oscalar"); # 19 | |
119 | test ( $a eq "087"); # 20 | |
120 | test ( $b eq "88"); # 21 | |
121 | test (ref $a eq "Oscalar"); # 22 | |
122 | ||
123 | eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; | |
124 | ||
125 | $b=$a; | |
126 | ||
127 | test (ref $a eq "Oscalar"); # 23 | |
128 | ||
129 | $b++; | |
130 | ||
131 | test (ref $b eq "Oscalar"); # 24 | |
132 | test ( $a eq "087"); # 25 | |
133 | test ( $b eq "88"); # 26 | |
134 | test (ref $a eq "Oscalar"); # 27 | |
135 | ||
136 | package Oscalar; | |
137 | $dummy=bless \$dummy; # Now cache of method should be reloaded | |
138 | package main; | |
139 | ||
140 | $b=$a; | |
141 | $b++; | |
142 | ||
143 | test (ref $b eq "Oscalar"); # 28 | |
144 | test ( $a eq "087"); # 29 | |
145 | test ( $b eq "88"); # 30 | |
146 | test (ref $a eq "Oscalar"); # 31 | |
147 | ||
32251b26 | 148 | undef $b; # Destroying updates tables too... |
8ebc5c01 | 149 | |
150 | eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; | |
151 | ||
152 | $b=$a; | |
153 | ||
154 | test (ref $a eq "Oscalar"); # 32 | |
155 | ||
156 | $b++; | |
157 | ||
158 | test (ref $b eq "Oscalar"); # 33 | |
159 | test ( $a eq "087"); # 34 | |
160 | test ( $b eq "88"); # 35 | |
161 | test (ref $a eq "Oscalar"); # 36 | |
162 | ||
163 | package Oscalar; | |
164 | $dummy=bless \$dummy; # Now cache of method should be reloaded | |
165 | package main; | |
166 | ||
167 | $b++; | |
168 | ||
169 | test (ref $b eq "Oscalar"); # 37 | |
170 | test ( $a eq "087"); # 38 | |
171 | test ( $b eq "90"); # 39 | |
172 | test (ref $a eq "Oscalar"); # 40 | |
173 | ||
174 | $b=$a; | |
175 | $b++; | |
176 | ||
177 | test (ref $b eq "Oscalar"); # 41 | |
178 | test ( $a eq "087"); # 42 | |
179 | test ( $b eq "89"); # 43 | |
180 | test (ref $a eq "Oscalar"); # 44 | |
181 | ||
182 | ||
183 | test ($b? 1:0); # 45 | |
184 | ||
185 | eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; | |
186 | package Oscalar; | |
187 | local $new=$ {$_[0]}; | |
188 | bless \$new } ) ]; | |
189 | ||
190 | $b=new Oscalar "$a"; | |
191 | ||
192 | test (ref $b eq "Oscalar"); # 46 | |
193 | test ( $a eq "087"); # 47 | |
194 | test ( $b eq "087"); # 48 | |
195 | test (ref $a eq "Oscalar"); # 49 | |
196 | ||
197 | $b++; | |
198 | ||
199 | test (ref $b eq "Oscalar"); # 50 | |
200 | test ( $a eq "087"); # 51 | |
201 | test ( $b eq "89"); # 52 | |
202 | test (ref $a eq "Oscalar"); # 53 | |
203 | test ($copies == 0); # 54 | |
204 | ||
205 | $b+=1; | |
206 | ||
207 | test (ref $b eq "Oscalar"); # 55 | |
208 | test ( $a eq "087"); # 56 | |
209 | test ( $b eq "90"); # 57 | |
210 | test (ref $a eq "Oscalar"); # 58 | |
211 | test ($copies == 0); # 59 | |
212 | ||
213 | $b=$a; | |
214 | $b+=1; | |
215 | ||
216 | test (ref $b eq "Oscalar"); # 60 | |
217 | test ( $a eq "087"); # 61 | |
218 | test ( $b eq "88"); # 62 | |
219 | test (ref $a eq "Oscalar"); # 63 | |
220 | test ($copies == 0); # 64 | |
221 | ||
222 | $b=$a; | |
223 | $b++; | |
224 | ||
225 | test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 | |
226 | test ( $a eq "087"); # 66 | |
227 | test ( $b eq "89"); # 67 | |
228 | test (ref $a eq "Oscalar"); # 68 | |
229 | test ($copies == 1); # 69 | |
230 | ||
231 | eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; | |
232 | $_[0] } ) ]; | |
233 | $c=new Oscalar; # Cause rehash | |
234 | ||
235 | $b=$a; | |
236 | $b+=1; | |
237 | ||
238 | test (ref $b eq "Oscalar"); # 70 | |
239 | test ( $a eq "087"); # 71 | |
240 | test ( $b eq "90"); # 72 | |
241 | test (ref $a eq "Oscalar"); # 73 | |
242 | test ($copies == 2); # 74 | |
243 | ||
244 | $b+=$b; | |
245 | ||
246 | test (ref $b eq "Oscalar"); # 75 | |
247 | test ( $b eq "360"); # 76 | |
248 | test ($copies == 2); # 77 | |
249 | $b=-$b; | |
250 | ||
251 | test (ref $b eq "Oscalar"); # 78 | |
252 | test ( $b eq "-360"); # 79 | |
253 | test ($copies == 2); # 80 | |
254 | ||
255 | $b=abs($b); | |
256 | ||
257 | test (ref $b eq "Oscalar"); # 81 | |
258 | test ( $b eq "360"); # 82 | |
259 | test ($copies == 2); # 83 | |
260 | ||
261 | $b=abs($b); | |
262 | ||
263 | test (ref $b eq "Oscalar"); # 84 | |
264 | test ( $b eq "360"); # 85 | |
265 | test ($copies == 2); # 86 | |
266 | ||
267 | eval q[package Oscalar; | |
268 | use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} | |
269 | : "_.${$_[0]}._" x $_[1])}) ]; | |
270 | ||
271 | $a=new Oscalar "yy"; | |
272 | $a x= 3; | |
273 | test ($a eq "_.yy.__.yy.__.yy._"); # 87 | |
274 | ||
275 | eval q[package Oscalar; | |
276 | use overload ('.' => sub {new Oscalar ( $_[2] ? | |
277 | "_.$_[1].__.$ {$_[0]}._" | |
278 | : "_.$ {$_[0]}.__.$_[1]._")}) ]; | |
279 | ||
280 | $a=new Oscalar "xx"; | |
281 | ||
282 | test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 | |
283 | ||
284 | # Check inheritance of overloading; | |
285 | { | |
286 | package OscalarI; | |
287 | @ISA = 'Oscalar'; | |
288 | } | |
289 | ||
290 | $aI = new OscalarI "$a"; | |
291 | test (ref $aI eq "OscalarI"); # 89 | |
292 | test ("$aI" eq "xx"); # 90 | |
293 | test ($aI eq "xx"); # 91 | |
294 | test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 | |
295 | ||
296 | # Here we test blessing to a package updates hash | |
297 | ||
298 | eval "package Oscalar; no overload '.'"; | |
299 | ||
300 | test ("b${a}" eq "_.b.__.xx._"); # 93 | |
301 | $x="1"; | |
302 | bless \$x, Oscalar; | |
303 | test ("b${a}c" eq "bxxc"); # 94 | |
304 | new Oscalar 1; | |
305 | test ("b${a}c" eq "bxxc"); # 95 | |
306 | ||
307 | # Negative overloading: | |
308 | ||
309 | $na = eval { ~$a }; | |
310 | test($@ =~ /no method found/); # 96 | |
311 | ||
312 | # Check AUTOLOADING: | |
313 | ||
314 | *Oscalar::AUTOLOAD = | |
315 | sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; | |
316 | goto &{"Oscalar::$AUTOLOAD"}}; | |
317 | ||
44a8e56a | 318 | eval "package Oscalar; sub comple; use overload '~' => 'comple'"; |
8ebc5c01 | 319 | |
320 | $na = eval { ~$a }; # Hash was not updated | |
321 | test($@ =~ /no method found/); # 97 | |
322 | ||
323 | bless \$x, Oscalar; | |
324 | ||
325 | $na = eval { ~$a }; # Hash updated | |
44a8e56a | 326 | warn "`$na', $@" if $@; |
8ebc5c01 | 327 | test !$@; # 98 |
328 | test($na eq '_!_xx_!_'); # 99 | |
329 | ||
330 | $na = 0; | |
331 | ||
332 | $na = eval { ~$aI }; # Hash was not updated | |
333 | test($@ =~ /no method found/); # 100 | |
334 | ||
335 | bless \$x, OscalarI; | |
336 | ||
337 | $na = eval { ~$aI }; | |
338 | print $@; | |
339 | ||
340 | test !$@; # 101 | |
341 | test($na eq '_!_xx_!_'); # 102 | |
342 | ||
44a8e56a | 343 | eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; |
8ebc5c01 | 344 | |
345 | $na = eval { $aI >> 1 }; # Hash was not updated | |
346 | test($@ =~ /no method found/); # 103 | |
347 | ||
348 | bless \$x, OscalarI; | |
349 | ||
350 | $na = 0; | |
351 | ||
352 | $na = eval { $aI >> 1 }; | |
353 | print $@; | |
354 | ||
355 | test !$@; # 104 | |
356 | test($na eq '_!_xx_!_'); # 105 | |
357 | ||
44a8e56a | 358 | # warn overload::Method($a, '0+'), "\n"; |
8ebc5c01 | 359 | test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 |
360 | test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 | |
361 | test (overload::Overloaded($aI)); # 108 | |
362 | test (!overload::Overloaded('overload')); # 109 | |
363 | ||
364 | test (! defined overload::Method($aI, '<<')); # 110 | |
365 | test (! defined overload::Method($a, '<')); # 111 | |
366 | ||
367 | test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 | |
368 | test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 | |
369 | ||
44a8e56a | 370 | # Check overloading by methods (specified deep in the ISA tree). |
371 | { | |
372 | package OscalarII; | |
373 | @ISA = 'OscalarI'; | |
374 | sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} | |
375 | eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; | |
376 | } | |
377 | ||
378 | $aaII = "087"; | |
379 | $aII = \$aaII; | |
380 | bless $aII, 'OscalarII'; | |
381 | bless \$fake, 'OscalarI'; # update the hash | |
382 | test(($aI | 3) eq '_<<_xx_<<_'); # 114 | |
383 | # warn $aII << 3; | |
384 | test(($aII << 3) eq '_<<_087_<<_'); # 115 | |
385 | ||
b3ac6de7 IZ |
386 | { |
387 | BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } | |
388 | $out = 2**10; | |
389 | } | |
390 | test($int, 9); # 116 | |
391 | test($out, 1024); # 117 | |
392 | ||
393 | $foo = 'foo'; | |
394 | $foo1 = 'f\'o\\o'; | |
395 | { | |
396 | BEGIN { $q = $qr = 7; | |
397 | overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, | |
398 | 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } | |
399 | $out = 'foo'; | |
400 | $out1 = 'f\'o\\o'; | |
401 | $out2 = "a\a$foo,\,"; | |
402 | /b\b$foo.\./; | |
403 | } | |
404 | ||
405 | test($out, 'foo'); # 118 | |
406 | test($out, $foo); # 119 | |
407 | test($out1, 'f\'o\\o'); # 120 | |
408 | test($out1, $foo1); # 121 | |
409 | test($out2, "a\afoo,\,"); # 122 | |
410 | test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 | |
411 | test($q, 11); # 124 | |
412 | test("@qr", "b\\b qq .\\. qq"); # 125 | |
413 | test($qr, 9); # 126 | |
414 | ||
415 | { | |
416 | $_ = '!<b>!foo!<-.>!'; | |
417 | BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, | |
418 | 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } | |
419 | $out = 'foo'; | |
420 | $out1 = 'f\'o\\o'; | |
421 | $out2 = "a\a$foo,\,"; | |
422 | $res = /b\b$foo.\./; | |
423 | $a = <<EOF; | |
424 | oups | |
425 | EOF | |
426 | $b = <<'EOF'; | |
427 | oups1 | |
428 | EOF | |
429 | $c = bareword; | |
430 | m'try it'; | |
431 | s'first part'second part'; | |
432 | s/yet another/tail here/; | |
c2e66d9e | 433 | tr/A-Z/a-z/; |
b3ac6de7 IZ |
434 | } |
435 | ||
436 | test($out, '_<foo>_'); # 117 | |
437 | test($out1, '_<f\'o\\o>_'); # 128 | |
438 | test($out2, "_<a\a>_foo_<,\,>_"); # 129 | |
439 | test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups | |
440 | qq oups1 | |
c2e66d9e | 441 | q second part q tail here s A-Z tr a-z tr"); # 130 |
b3ac6de7 IZ |
442 | test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 |
443 | test($res, 1); # 132 | |
444 | test($a, "_<oups | |
445 | >_"); # 133 | |
446 | test($b, "_<oups1 | |
447 | >_"); # 134 | |
448 | test($c, "bareword"); # 135 | |
449 | ||
ee239bfe IZ |
450 | { |
451 | package symbolic; # Primitive symbolic calculator | |
452 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, | |
453 | '=' => \&cpy, '++' => \&inc, '--' => \&dec; | |
454 | ||
455 | sub new { shift; bless ['n', @_] } | |
456 | sub cpy { | |
457 | my $self = shift; | |
458 | bless [@$self], ref $self; | |
459 | } | |
460 | sub inc { $_[0] = bless ['++', $_[0], 1]; } | |
461 | sub dec { $_[0] = bless ['--', $_[0], 1]; } | |
462 | sub wrap { | |
463 | my ($obj, $other, $inv, $meth) = @_; | |
464 | if ($meth eq '++' or $meth eq '--') { | |
465 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference | |
466 | return $obj; | |
467 | } | |
468 | ($obj, $other) = ($other, $obj) if $inv; | |
469 | bless [$meth, $obj, $other]; | |
470 | } | |
471 | sub str { | |
472 | my ($meth, $a, $b) = @{+shift}; | |
473 | $a = 'u' unless defined $a; | |
474 | if (defined $b) { | |
475 | "[$meth $a $b]"; | |
476 | } else { | |
477 | "[$meth $a]"; | |
478 | } | |
479 | } | |
480 | my %subr = ( 'n' => sub {$_[0]} ); | |
481 | foreach my $op (split " ", $overload::ops{with_assign}) { | |
482 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; | |
483 | } | |
484 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); | |
485 | foreach my $op (split " ", "@overload::ops{ @bins }") { | |
486 | $subr{$op} = eval "sub {shift() $op shift()}"; | |
487 | } | |
488 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { | |
489 | $subr{$op} = eval "sub {$op shift()}"; | |
490 | } | |
491 | $subr{'++'} = $subr{'+'}; | |
492 | $subr{'--'} = $subr{'-'}; | |
493 | ||
494 | sub num { | |
495 | my ($meth, $a, $b) = @{+shift}; | |
496 | my $subr = $subr{$meth} | |
497 | or die "Do not know how to ($meth) in symbolic"; | |
498 | $a = $a->num if ref $a eq __PACKAGE__; | |
499 | $b = $b->num if ref $b eq __PACKAGE__; | |
500 | $subr->($a,$b); | |
501 | } | |
502 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } | |
503 | sub FETCH { shift } | |
504 | sub nop { } # Around a bug | |
505 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } | |
506 | sub STORE { | |
507 | my $obj = shift; | |
508 | $#$obj = 1; | |
a1063b2d | 509 | $obj->[1] = shift; |
ee239bfe IZ |
510 | } |
511 | } | |
512 | ||
513 | { | |
514 | my $foo = new symbolic 11; | |
515 | my $baz = $foo++; | |
516 | test( (sprintf "%d", $foo), '12'); | |
517 | test( (sprintf "%d", $baz), '11'); | |
518 | my $bar = $foo; | |
519 | $baz = ++$foo; | |
520 | test( (sprintf "%d", $foo), '13'); | |
521 | test( (sprintf "%d", $bar), '12'); | |
522 | test( (sprintf "%d", $baz), '13'); | |
523 | my $ban = $foo; | |
524 | $baz = ($foo += 1); | |
525 | test( (sprintf "%d", $foo), '14'); | |
526 | test( (sprintf "%d", $bar), '12'); | |
527 | test( (sprintf "%d", $baz), '14'); | |
528 | test( (sprintf "%d", $ban), '13'); | |
529 | $baz = 0; | |
530 | $baz = $foo++; | |
531 | test( (sprintf "%d", $foo), '15'); | |
532 | test( (sprintf "%d", $baz), '14'); | |
533 | test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); | |
534 | } | |
535 | ||
536 | { | |
537 | my $iter = new symbolic 2; | |
538 | my $side = new symbolic 1; | |
539 | my $cnt = $iter; | |
540 | ||
541 | while ($cnt) { | |
542 | $cnt = $cnt - 1; # The "simple" way | |
543 | $side = (sqrt(1 + $side**2) - 1)/$side; | |
544 | } | |
545 | my $pi = $side*(2**($iter+2)); | |
546 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; | |
547 | test( (sprintf "%f", $pi), '3.182598'); | |
548 | } | |
549 | ||
550 | { | |
551 | my $iter = new symbolic 2; | |
552 | my $side = new symbolic 1; | |
553 | my $cnt = $iter; | |
554 | ||
555 | while ($cnt--) { | |
556 | $side = (sqrt(1 + $side**2) - 1)/$side; | |
557 | } | |
558 | my $pi = $side*(2**($iter+2)); | |
559 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; | |
560 | test( (sprintf "%f", $pi), '3.182598'); | |
561 | } | |
562 | ||
563 | { | |
564 | my ($a, $b); | |
565 | symbolic->vars($a, $b); | |
566 | my $c = sqrt($a**2 + $b**2); | |
567 | $a = 3; $b = 4; | |
568 | test( (sprintf "%d", $c), '5'); | |
569 | $a = 12; $b = 5; | |
570 | test( (sprintf "%d", $c), '13'); | |
571 | } | |
572 | ||
573 | { | |
574 | package symbolic1; # Primitive symbolic calculator | |
575 | # Mutator inc/dec | |
576 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; | |
577 | ||
578 | sub new { shift; bless ['n', @_] } | |
579 | sub cpy { | |
580 | my $self = shift; | |
581 | bless [@$self], ref $self; | |
582 | } | |
583 | sub wrap { | |
584 | my ($obj, $other, $inv, $meth) = @_; | |
585 | if ($meth eq '++' or $meth eq '--') { | |
586 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference | |
587 | return $obj; | |
588 | } | |
589 | ($obj, $other) = ($other, $obj) if $inv; | |
590 | bless [$meth, $obj, $other]; | |
591 | } | |
592 | sub str { | |
593 | my ($meth, $a, $b) = @{+shift}; | |
594 | $a = 'u' unless defined $a; | |
595 | if (defined $b) { | |
596 | "[$meth $a $b]"; | |
597 | } else { | |
598 | "[$meth $a]"; | |
599 | } | |
600 | } | |
601 | my %subr = ( 'n' => sub {$_[0]} ); | |
602 | foreach my $op (split " ", $overload::ops{with_assign}) { | |
603 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; | |
604 | } | |
605 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); | |
606 | foreach my $op (split " ", "@overload::ops{ @bins }") { | |
607 | $subr{$op} = eval "sub {shift() $op shift()}"; | |
608 | } | |
609 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { | |
610 | $subr{$op} = eval "sub {$op shift()}"; | |
611 | } | |
612 | $subr{'++'} = $subr{'+'}; | |
613 | $subr{'--'} = $subr{'-'}; | |
614 | ||
615 | sub num { | |
616 | my ($meth, $a, $b) = @{+shift}; | |
617 | my $subr = $subr{$meth} | |
618 | or die "Do not know how to ($meth) in symbolic"; | |
619 | $a = $a->num if ref $a eq __PACKAGE__; | |
620 | $b = $b->num if ref $b eq __PACKAGE__; | |
621 | $subr->($a,$b); | |
622 | } | |
623 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } | |
624 | sub FETCH { shift } | |
625 | sub nop { } # Around a bug | |
626 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } | |
627 | sub STORE { | |
628 | my $obj = shift; | |
629 | $#$obj = 1; | |
a1063b2d | 630 | $obj->[1] = shift; |
ee239bfe IZ |
631 | } |
632 | } | |
633 | ||
634 | { | |
635 | my $foo = new symbolic1 11; | |
636 | my $baz = $foo++; | |
637 | test( (sprintf "%d", $foo), '12'); | |
638 | test( (sprintf "%d", $baz), '11'); | |
639 | my $bar = $foo; | |
640 | $baz = ++$foo; | |
641 | test( (sprintf "%d", $foo), '13'); | |
642 | test( (sprintf "%d", $bar), '12'); | |
643 | test( (sprintf "%d", $baz), '13'); | |
644 | my $ban = $foo; | |
645 | $baz = ($foo += 1); | |
646 | test( (sprintf "%d", $foo), '14'); | |
647 | test( (sprintf "%d", $bar), '12'); | |
648 | test( (sprintf "%d", $baz), '14'); | |
649 | test( (sprintf "%d", $ban), '13'); | |
650 | $baz = 0; | |
651 | $baz = $foo++; | |
652 | test( (sprintf "%d", $foo), '15'); | |
653 | test( (sprintf "%d", $baz), '14'); | |
654 | test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); | |
655 | } | |
656 | ||
657 | { | |
658 | my $iter = new symbolic1 2; | |
659 | my $side = new symbolic1 1; | |
660 | my $cnt = $iter; | |
661 | ||
662 | while ($cnt) { | |
663 | $cnt = $cnt - 1; # The "simple" way | |
664 | $side = (sqrt(1 + $side**2) - 1)/$side; | |
665 | } | |
666 | my $pi = $side*(2**($iter+2)); | |
667 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; | |
668 | test( (sprintf "%f", $pi), '3.182598'); | |
669 | } | |
670 | ||
671 | { | |
672 | my $iter = new symbolic1 2; | |
673 | my $side = new symbolic1 1; | |
674 | my $cnt = $iter; | |
675 | ||
676 | while ($cnt--) { | |
677 | $side = (sqrt(1 + $side**2) - 1)/$side; | |
678 | } | |
679 | my $pi = $side*(2**($iter+2)); | |
680 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; | |
681 | test( (sprintf "%f", $pi), '3.182598'); | |
682 | } | |
683 | ||
684 | { | |
685 | my ($a, $b); | |
686 | symbolic1->vars($a, $b); | |
687 | my $c = sqrt($a**2 + $b**2); | |
688 | $a = 3; $b = 4; | |
689 | test( (sprintf "%d", $c), '5'); | |
690 | $a = 12; $b = 5; | |
691 | test( (sprintf "%d", $c), '13'); | |
692 | } | |
693 | ||
694 | { | |
695 | package two_face; # Scalars with separate string and | |
696 | # numeric values. | |
697 | sub new { my $p = shift; bless [@_], $p } | |
698 | use overload '""' => \&str, '0+' => \&num, fallback => 1; | |
699 | sub num {shift->[1]} | |
700 | sub str {shift->[0]} | |
701 | } | |
702 | ||
703 | { | |
704 | my $seven = new two_face ("vii", 7); | |
705 | test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), | |
706 | 'seven=vii, seven=7, eight=8'); | |
707 | test( scalar ($seven =~ /i/), '1') | |
708 | } | |
b3ac6de7 | 709 | |
d0ecd44c IZ |
710 | { |
711 | package sorting; | |
712 | use overload 'cmp' => \∁ | |
713 | sub new { my ($p, $v) = @_; bless \$v, $p } | |
714 | sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } | |
715 | } | |
716 | { | |
717 | my @arr = map sorting->new($_), 0..12; | |
718 | my @sorted1 = sort @arr; | |
719 | my @sorted2 = map $$_, @sorted1; | |
720 | test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; | |
721 | } | |
f5284f61 IZ |
722 | { |
723 | package iterator; | |
724 | use overload '<>' => \&iter; | |
725 | sub new { my ($p, $v) = @_; bless \$v, $p } | |
726 | sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } | |
727 | } | |
72b16652 GS |
728 | |
729 | # XXX iterator overload not intended to work with CORE::GLOBAL? | |
730 | if (defined &CORE::GLOBAL::glob) { | |
731 | test '1', '1'; # 175 | |
732 | test '1', '1'; # 176 | |
733 | test '1', '1'; # 177 | |
734 | } | |
735 | else { | |
f5284f61 IZ |
736 | my $iter = iterator->new(5); |
737 | my $acc = ''; | |
738 | my $out; | |
739 | $acc .= " $out" while $out = <${iter}>; | |
740 | test $acc, ' 5 4 3 2 1 0'; # 175 | |
741 | $iter = iterator->new(5); | |
742 | test scalar <${iter}>, '5'; # 176 | |
743 | $acc = ''; | |
b04ef359 | 744 | $acc .= " $out" while $out = <$iter>; |
f5284f61 IZ |
745 | test $acc, ' 4 3 2 1 0'; # 177 |
746 | } | |
747 | { | |
748 | package deref; | |
749 | use overload '%{}' => \&hderef, '&{}' => \&cderef, | |
750 | '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; | |
751 | sub new { my ($p, $v) = @_; bless \$v, $p } | |
752 | sub deref { | |
753 | my ($self, $key) = (shift, shift); | |
754 | my $class = ref $self; | |
755 | bless $self, 'deref::dummy'; # Disable overloading of %{} | |
756 | my $out = $self->{$key}; | |
757 | bless $self, $class; # Restore overloading | |
758 | $out; | |
759 | } | |
760 | sub hderef {shift->deref('h')} | |
761 | sub aderef {shift->deref('a')} | |
762 | sub cderef {shift->deref('c')} | |
763 | sub gderef {shift->deref('g')} | |
764 | sub sderef {shift->deref('s')} | |
765 | } | |
766 | { | |
767 | my $deref = bless { h => { foo => 5 , fake => 23 }, | |
768 | c => sub {return shift() + 34}, | |
769 | 's' => \123, | |
770 | a => [11..13], | |
771 | g => \*srt, | |
772 | }, 'deref'; | |
773 | # Hash: | |
774 | my @cont = sort %$deref; | |
f70c35af GS |
775 | if ("\t" eq "\011") { # ascii |
776 | test "@cont", '23 5 fake foo'; # 178 | |
777 | } | |
778 | else { # ebcdic alpha-numeric sort order | |
779 | test "@cont", 'fake foo 23 5'; # 178 | |
780 | } | |
f5284f61 IZ |
781 | my @keys = sort keys %$deref; |
782 | test "@keys", 'fake foo'; # 179 | |
783 | my @val = sort values %$deref; | |
784 | test "@val", '23 5'; # 180 | |
785 | test $deref->{foo}, 5; # 181 | |
786 | test defined $deref->{bar}, ''; # 182 | |
787 | my $key; | |
788 | @keys = (); | |
789 | push @keys, $key while $key = each %$deref; | |
790 | @keys = sort @keys; | |
791 | test "@keys", 'fake foo'; # 183 | |
792 | test exists $deref->{bar}, ''; # 184 | |
793 | test exists $deref->{foo}, 1; # 185 | |
794 | # Code: | |
795 | test $deref->(5), 39; # 186 | |
796 | test &$deref(6), 40; # 187 | |
797 | sub xxx_goto { goto &$deref } | |
798 | test xxx_goto(7), 41; # 188 | |
799 | my $srt = bless { c => sub {$b <=> $a} | |
800 | }, 'deref'; | |
801 | *srt = \&$srt; | |
802 | my @sorted = sort srt 11, 2, 5, 1, 22; | |
803 | test "@sorted", '22 11 5 2 1'; # 189 | |
804 | # Scalar | |
805 | test $$deref, 123; # 190 | |
c6e96bcb GS |
806 | # Code |
807 | @sorted = sort $srt 11, 2, 5, 1, 22; | |
f5284f61 IZ |
808 | test "@sorted", '22 11 5 2 1'; # 191 |
809 | # Array | |
810 | test "@$deref", '11 12 13'; # 192 | |
811 | test $#$deref, '2'; # 193 | |
812 | my $l = @$deref; | |
813 | test $l, 3; # 194 | |
814 | test $deref->[2], '13'; # 195 | |
815 | $l = pop @$deref; | |
816 | test $l, 13; # 196 | |
817 | $l = 1; | |
818 | test $deref->[$l], '12'; # 197 | |
819 | # Repeated dereference | |
820 | my $double = bless { h => $deref, | |
821 | }, 'deref'; | |
822 | test $double->{foo}, 5; # 198 | |
823 | } | |
824 | ||
825 | { | |
826 | package two_refs; | |
827 | use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; | |
828 | sub new { | |
829 | my $p = shift; | |
830 | bless \ [@_], $p; | |
831 | } | |
832 | sub gethash { | |
833 | my %h; | |
834 | my $self = shift; | |
835 | tie %h, ref $self, $self; | |
836 | \%h; | |
837 | } | |
838 | ||
839 | sub TIEHASH { my $p = shift; bless \ shift, $p } | |
840 | my %fields; | |
841 | my $i = 0; | |
842 | $fields{$_} = $i++ foreach qw{zero one two three}; | |
843 | sub STORE { | |
844 | my $self = ${shift()}; | |
845 | my $key = $fields{shift()}; | |
846 | defined $key or die "Out of band access"; | |
847 | $$self->[$key] = shift; | |
848 | } | |
849 | sub FETCH { | |
850 | my $self = ${shift()}; | |
851 | my $key = $fields{shift()}; | |
852 | defined $key or die "Out of band access"; | |
853 | $$self->[$key]; | |
854 | } | |
855 | } | |
856 | ||
857 | my $bar = new two_refs 3,4,5,6; | |
858 | $bar->[2] = 11; | |
859 | test $bar->{two}, 11; # 199 | |
860 | $bar->{three} = 13; | |
861 | test $bar->[3], 13; # 200 | |
862 | ||
863 | { | |
864 | package two_refs_o; | |
865 | @ISA = ('two_refs'); | |
866 | } | |
867 | ||
868 | $bar = new two_refs_o 3,4,5,6; | |
869 | $bar->[2] = 11; | |
870 | test $bar->{two}, 11; # 201 | |
871 | $bar->{three} = 13; | |
872 | test $bar->[3], 13; # 202 | |
873 | ||
874 | { | |
875 | package two_refs1; | |
876 | use overload '%{}' => sub { ${shift()}->[1] }, | |
877 | '@{}' => sub { ${shift()}->[0] }; | |
878 | sub new { | |
879 | my $p = shift; | |
880 | my $a = [@_]; | |
881 | my %h; | |
882 | tie %h, $p, $a; | |
883 | bless \ [$a, \%h], $p; | |
884 | } | |
885 | sub gethash { | |
886 | my %h; | |
887 | my $self = shift; | |
888 | tie %h, ref $self, $self; | |
889 | \%h; | |
890 | } | |
891 | ||
892 | sub TIEHASH { my $p = shift; bless \ shift, $p } | |
893 | my %fields; | |
894 | my $i = 0; | |
895 | $fields{$_} = $i++ foreach qw{zero one two three}; | |
896 | sub STORE { | |
897 | my $a = ${shift()}; | |
898 | my $key = $fields{shift()}; | |
899 | defined $key or die "Out of band access"; | |
900 | $a->[$key] = shift; | |
901 | } | |
902 | sub FETCH { | |
903 | my $a = ${shift()}; | |
904 | my $key = $fields{shift()}; | |
905 | defined $key or die "Out of band access"; | |
906 | $a->[$key]; | |
907 | } | |
908 | } | |
909 | ||
910 | $bar = new two_refs_o 3,4,5,6; | |
911 | $bar->[2] = 11; | |
912 | test $bar->{two}, 11; # 203 | |
913 | $bar->{three} = 13; | |
914 | test $bar->[3], 13; # 204 | |
915 | ||
916 | { | |
917 | package two_refs1_o; | |
918 | @ISA = ('two_refs1'); | |
919 | } | |
920 | ||
921 | $bar = new two_refs1_o 3,4,5,6; | |
922 | $bar->[2] = 11; | |
923 | test $bar->{two}, 11; # 205 | |
924 | $bar->{three} = 13; | |
925 | test $bar->[3], 13; # 206 | |
926 | ||
fe7ac86a IZ |
927 | { |
928 | package B; | |
929 | use overload bool => sub { ${+shift} }; | |
930 | } | |
931 | ||
932 | my $aaa; | |
933 | { my $bbbb = 0; $aaa = bless \$bbbb, B } | |
934 | ||
1426bbf4 | 935 | test !$aaa, 1; # 207 |
fe7ac86a IZ |
936 | |
937 | unless ($aaa) { | |
1426bbf4 | 938 | test 'ok', 'ok'; # 208 |
fe7ac86a | 939 | } else { |
1426bbf4 | 940 | test 'is not', 'ok'; # 208 |
fe7ac86a IZ |
941 | } |
942 | ||
1426bbf4 MG |
943 | # check that overload isn't done twice by join |
944 | { my $c = 0; | |
945 | package Join; | |
946 | use overload '""' => sub { $c++ }; | |
947 | my $x = join '', bless([]), 'pq', bless([]); | |
948 | main::test $x, '0pq1'; # 209 | |
949 | }; | |
fe7ac86a | 950 | |
4498a751 PM |
951 | # Test module-specific warning |
952 | { | |
953 | # check the Odd number of arguments for overload::constant warning | |
954 | my $a = "" ; | |
0a911d86 | 955 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 PM |
956 | $x = eval ' overload::constant "integer" ; ' ; |
957 | test($a eq "") ; # 210 | |
958 | use warnings 'overload' ; | |
959 | $x = eval ' overload::constant "integer" ; ' ; | |
960 | test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 | |
961 | } | |
962 | ||
963 | { | |
964 | # check the `$_[0]' is not an overloadable type warning | |
965 | my $a = "" ; | |
0a911d86 | 966 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 PM |
967 | $x = eval ' overload::constant "fred" => sub {} ; ' ; |
968 | test($a eq "") ; # 212 | |
969 | use warnings 'overload' ; | |
970 | $x = eval ' overload::constant "fred" => sub {} ; ' ; | |
971 | test($a =~ /^`fred' is not an overloadable type at/); # 213 | |
972 | } | |
973 | ||
974 | { | |
975 | # check the `$_[1]' is not a code reference warning | |
976 | my $a = "" ; | |
0a911d86 | 977 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 PM |
978 | $x = eval ' overload::constant "integer" => 1; ' ; |
979 | test($a eq "") ; # 214 | |
980 | use warnings 'overload' ; | |
981 | $x = eval ' overload::constant "integer" => 1; ' ; | |
982 | test($a =~ /^`1' is not a code reference at/); # 215 | |
983 | } | |
984 | ||
78f67eb5 JH |
985 | { |
986 | my $c = 0; | |
987 | package ov_int1; | |
988 | use overload '""' => sub { 3+shift->[0] }, | |
989 | '0+' => sub { 10+shift->[0] }, | |
990 | 'int' => sub { 100+shift->[0] }; | |
991 | sub new {my $p = shift; bless [shift], $p} | |
992 | ||
993 | package ov_int2; | |
994 | use overload '""' => sub { 5+shift->[0] }, | |
995 | '0+' => sub { 30+shift->[0] }, | |
996 | 'int' => sub { 'ov_int1'->new(1000+shift->[0]) }; | |
997 | sub new {my $p = shift; bless [shift], $p} | |
998 | ||
999 | package noov_int; | |
1000 | use overload '""' => sub { 2+shift->[0] }, | |
1001 | '0+' => sub { 9+shift->[0] }; | |
1002 | sub new {my $p = shift; bless [shift], $p} | |
1003 | ||
1004 | package main; | |
1005 | ||
1006 | my $x = new noov_int 11; | |
1007 | my $int_x = int $x; | |
1008 | main::test("$int_x" eq 20); # 216 | |
1009 | $x = new ov_int1 31; | |
1010 | $int_x = int $x; | |
1011 | main::test("$int_x" eq 131); # 217 | |
1012 | $x = new ov_int2 51; | |
1013 | $int_x = int $x; | |
1014 | main::test("$int_x" eq 1054); # 218 | |
1015 | } | |
1016 | ||
1554e226 DC |
1017 | # make sure that we don't inifinitely recurse |
1018 | { | |
1019 | my $c = 0; | |
1020 | package Recurse; | |
1021 | use overload '""' => sub { shift }, | |
1022 | '0+' => sub { shift }, | |
1023 | 'bool' => sub { shift }, | |
1024 | fallback => 1; | |
1025 | my $x = bless([]); | |
78f67eb5 JH |
1026 | main::test("$x" =~ /Recurse=ARRAY/); # 219 |
1027 | main::test($x); # 220 | |
1028 | main::test($x+0 =~ /Recurse=ARRAY/); # 221 | |
1029 | } | |
1030 | ||
1dc13c17 SC |
1031 | # BugID 20010422.003 |
1032 | package Foo; | |
1033 | ||
1034 | use overload | |
1035 | 'bool' => sub { return !$_[0]->is_zero() || undef; } | |
1036 | ; | |
1037 | ||
1038 | sub is_zero | |
1039 | { | |
1040 | my $self = shift; | |
1041 | return $self->{var} == 0; | |
1042 | } | |
1043 | ||
1044 | sub new | |
1045 | { | |
1046 | my $class = shift; | |
1047 | my $self = {}; | |
1048 | $self->{var} = shift; | |
1049 | bless $self,$class; | |
1050 | } | |
1051 | ||
1052 | package main; | |
1053 | ||
1054 | use strict; | |
1055 | ||
1056 | my $r = Foo->new(8); | |
1057 | $r = Foo->new(0); | |
78f67eb5 | 1058 | |
e89a8b87 | 1059 | test(($r || 0) == 0); # 222 |
1554e226 | 1060 | |
6050d10e JP |
1061 | package utf8_o; |
1062 | ||
1063 | use overload | |
1064 | '""' => sub { return $_[0]->{var}; } | |
1065 | ; | |
1066 | ||
1067 | sub new | |
1068 | { | |
1069 | my $class = shift; | |
1070 | my $self = {}; | |
1071 | $self->{var} = shift; | |
1072 | bless $self,$class; | |
1073 | } | |
1074 | ||
1075 | package main; | |
1076 | ||
1077 | ||
1078 | my $utfvar = new utf8_o 200.2.1; | |
446eaa42 YST |
1079 | test("$utfvar" eq 200.2.1); # 223 - stringify |
1080 | test("a$utfvar" eq "a".200.2.1); # 224 - overload via sv_2pv_flags | |
6050d10e | 1081 | |
446eaa42 | 1082 | # 225..227 -- more %{} tests. Hangs in 5.6.0, okay in later releases. |
41cb1005 JH |
1083 | # Basically this example implements strong encapsulation: if Hderef::import() |
1084 | # were to eval the overload code in the caller's namespace, the privatisation | |
1085 | # would be quite transparent. | |
1086 | package Hderef; | |
1087 | use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" }; | |
1088 | package Foo; | |
1089 | @Foo::ISA = 'Hderef'; | |
1090 | sub new { bless {}, shift } | |
1091 | sub xet { @_ == 2 ? $_[0]->{$_[1]} : | |
1092 | @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef } | |
1093 | package main; | |
1094 | my $a = Foo->new; | |
1095 | $a->xet('b', 42); | |
61f33854 RGS |
1096 | test ($a->xet('b'), 42); |
1097 | test (!defined eval { $a->{b} }); | |
1098 | test ($@ =~ /zap/); | |
41cb1005 | 1099 | |
29ddfe35 RD |
1100 | { |
1101 | package t229; | |
1102 | use overload '=' => sub { 42 }, | |
1103 | '++' => sub { my $x = ${$_[0]}; $_[0] }; | |
1104 | sub new { my $x = 42; bless \$x } | |
1105 | ||
1106 | my $warn; | |
1107 | { | |
1108 | local $SIG{__WARN__} = sub { $warn++ }; | |
1109 | my $x = t229->new; | |
1110 | my $y = $x; | |
1111 | eval { $y++ }; | |
1112 | } | |
61f33854 RGS |
1113 | main::test (!$warn); |
1114 | } | |
1115 | ||
1116 | { | |
1117 | my ($int, $out1, $out2); | |
1118 | { | |
1119 | BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; } | |
1120 | $out1 = 0; | |
1121 | $out2 = 1; | |
1122 | } | |
1123 | test($int, 2, "#24313"); # 230 | |
1124 | test($out1, 17, "#24313"); # 231 | |
1125 | test($out2, 17, "#24313"); # 232 | |
29ddfe35 RD |
1126 | } |
1127 | ||
0bdaccee NC |
1128 | { |
1129 | package Numify; | |
1130 | use overload (qw(0+ numify fallback 1)); | |
1131 | ||
1132 | sub new { | |
1133 | my $val = $_[1]; | |
1134 | bless \$val, $_[0]; | |
1135 | } | |
1136 | ||
1137 | sub numify { ${$_[0]} } | |
1138 | } | |
1139 | ||
d411a6a9 RD |
1140 | { |
1141 | package perl31793; | |
1b1d102f RD |
1142 | use overload cmp => sub { 0 }; |
1143 | package perl31793_fb; | |
76c43448 | 1144 | use overload cmp => sub { 0 }, fallback => 1; |
d411a6a9 RD |
1145 | package main; |
1146 | my $o = bless [], 'perl31793'; | |
1b1d102f | 1147 | my $of = bless [], 'perl31793_fb'; |
d411a6a9 RD |
1148 | my $no = bless [], 'no_overload'; |
1149 | test (overload::StrVal(\"scalar") =~ /^SCALAR\(0x[0-9a-f]+\)$/); | |
1150 | test (overload::StrVal([]) =~ /^ARRAY\(0x[0-9a-f]+\)$/); | |
1151 | test (overload::StrVal({}) =~ /^HASH\(0x[0-9a-f]+\)$/); | |
1152 | test (overload::StrVal(sub{1}) =~ /^CODE\(0x[0-9a-f]+\)$/); | |
1153 | test (overload::StrVal(\*GLOB) =~ /^GLOB\(0x[0-9a-f]+\)$/); | |
1154 | test (overload::StrVal(\$o) =~ /^REF\(0x[0-9a-f]+\)$/); | |
1155 | test (overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/); | |
1156 | test (overload::StrVal($o) =~ /^perl31793=ARRAY\(0x[0-9a-f]+\)$/); | |
1b1d102f | 1157 | test (overload::StrVal($of) =~ /^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/); |
d411a6a9 RD |
1158 | test (overload::StrVal($no) =~ /^no_overload=ARRAY\(0x[0-9a-f]+\)$/); |
1159 | } | |
1160 | ||
0bdaccee NC |
1161 | # These are all check that overloaded values rather than reference addressess |
1162 | # are what is getting tested. | |
1163 | my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; | |
1164 | my ($ein, $zwei) = (1, 2); | |
1165 | ||
1166 | my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); | |
1167 | foreach my $op (qw(<=> == != < <= > >=)) { | |
1168 | foreach my $l (keys %map) { | |
1169 | foreach my $r (keys %map) { | |
1170 | my $ocode = "\$$l $op \$$r"; | |
1171 | my $rcode = "$map{$l} $op $map{$r}"; | |
1172 | ||
1173 | my $got = eval $ocode; | |
1174 | die if $@; | |
1175 | my $expect = eval $rcode; | |
1176 | die if $@; | |
1177 | test ($got, $expect, $ocode) or print "# $rcode\n"; | |
1178 | } | |
1179 | } | |
1180 | } | |
131b3ad0 DM |
1181 | { |
1182 | # check that overloading works in regexes | |
1183 | { | |
1184 | package Foo493; | |
1185 | use overload | |
1186 | '""' => sub { "^$_[0][0]\$" }, | |
1187 | '.' => sub { | |
1188 | bless [ | |
1189 | $_[2] | |
1190 | ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0] | |
1191 | : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1]) | |
1192 | ], 'Foo493' | |
1193 | }; | |
1194 | } | |
1195 | ||
1196 | my $a = bless [ "a" ], 'Foo493'; | |
1197 | test('a' =~ /$a/); | |
1198 | test('x:a' =~ /x$a/); | |
1199 | test('x:a:=' =~ /x$a=$/); | |
1200 | test('x:a:a:=' =~ /x$a$a=$/); | |
1201 | ||
1202 | } | |
1203 | ||
1204 | ||
8ebc5c01 | 1205 | # Last test is: |
1b1d102f | 1206 | sub last {497} |