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 |
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; |
11e3e2e4 |
51 | use Test::More tests=>498; |
8ebc5c01 |
52 | |
53 | sub test { |
b3ac6de7 |
54 | $test++; |
55 | if (@_ > 1) { |
61f33854 |
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 |
62 | $comment .= ": '$_[0]' ne '$_[1]'"; |
63 | print "not ok $test$comment\n"; |
0bdaccee |
64 | return 0; |
b3ac6de7 |
65 | } |
66 | } else { |
67 | if (shift) { |
68 | print "ok $test\n"; |
0bdaccee |
69 | return 1; |
b3ac6de7 |
70 | } else { |
71 | print "not ok $test\n"; |
0bdaccee |
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 | |
fdb7e2a2 |
332 | { |
333 | my $Test = Test::Builder->new; |
334 | $Test->current_test(99); |
335 | } |
8ebc5c01 |
336 | $na = eval { ~$aI }; # Hash was not updated |
fdb7e2a2 |
337 | like($@, qr/no method found/); |
8ebc5c01 |
338 | |
339 | bless \$x, OscalarI; |
340 | |
341 | $na = eval { ~$aI }; |
342 | print $@; |
343 | |
fdb7e2a2 |
344 | ok(!$@); |
345 | is($na, '_!_xx_!_'); |
8ebc5c01 |
346 | |
44a8e56a |
347 | eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; |
8ebc5c01 |
348 | |
349 | $na = eval { $aI >> 1 }; # Hash was not updated |
fdb7e2a2 |
350 | like($@, qr/no method found/); |
8ebc5c01 |
351 | |
352 | bless \$x, OscalarI; |
353 | |
354 | $na = 0; |
355 | |
356 | $na = eval { $aI >> 1 }; |
357 | print $@; |
358 | |
fdb7e2a2 |
359 | ok(!$@); |
360 | is($na, '_!_xx_!_'); |
8ebc5c01 |
361 | |
44a8e56a |
362 | # warn overload::Method($a, '0+'), "\n"; |
fdb7e2a2 |
363 | is(overload::Method($a, '0+'), \&Oscalar::numify); |
364 | is(overload::Method($aI,'0+'), \&Oscalar::numify); |
365 | ok(overload::Overloaded($aI)); |
366 | ok(!overload::Overloaded('overload')); |
8ebc5c01 |
367 | |
fdb7e2a2 |
368 | ok(! defined overload::Method($aI, '<<')); |
369 | ok(! defined overload::Method($a, '<')); |
8ebc5c01 |
370 | |
fdb7e2a2 |
371 | like (overload::StrVal($aI), qr/^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); |
372 | is(overload::StrVal(\$aI), "@{[\$aI]}"); |
8ebc5c01 |
373 | |
44a8e56a |
374 | # Check overloading by methods (specified deep in the ISA tree). |
375 | { |
376 | package OscalarII; |
377 | @ISA = 'OscalarI'; |
378 | sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} |
379 | eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; |
380 | } |
381 | |
382 | $aaII = "087"; |
383 | $aII = \$aaII; |
384 | bless $aII, 'OscalarII'; |
385 | bless \$fake, 'OscalarI'; # update the hash |
fdb7e2a2 |
386 | is(($aI | 3), '_<<_xx_<<_'); |
44a8e56a |
387 | # warn $aII << 3; |
fdb7e2a2 |
388 | is(($aII << 3), '_<<_087_<<_'); |
44a8e56a |
389 | |
b3ac6de7 |
390 | { |
391 | BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } |
392 | $out = 2**10; |
393 | } |
fdb7e2a2 |
394 | is($int, 9); |
395 | is($out, 1024); |
b3ac6de7 |
396 | |
397 | $foo = 'foo'; |
398 | $foo1 = 'f\'o\\o'; |
399 | { |
400 | BEGIN { $q = $qr = 7; |
401 | overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, |
402 | 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } |
403 | $out = 'foo'; |
404 | $out1 = 'f\'o\\o'; |
405 | $out2 = "a\a$foo,\,"; |
406 | /b\b$foo.\./; |
407 | } |
408 | |
fdb7e2a2 |
409 | is($out, 'foo'); |
410 | is($out, $foo); |
411 | is($out1, 'f\'o\\o'); |
412 | is($out1, $foo1); |
413 | is($out2, "a\afoo,\,"); |
414 | is("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); |
415 | is($q, 11); |
416 | is("@qr", "b\\b qq .\\. qq"); |
417 | is($qr, 9); |
b3ac6de7 |
418 | |
419 | { |
420 | $_ = '!<b>!foo!<-.>!'; |
421 | BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, |
422 | 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } |
423 | $out = 'foo'; |
424 | $out1 = 'f\'o\\o'; |
425 | $out2 = "a\a$foo,\,"; |
426 | $res = /b\b$foo.\./; |
427 | $a = <<EOF; |
428 | oups |
429 | EOF |
430 | $b = <<'EOF'; |
431 | oups1 |
432 | EOF |
433 | $c = bareword; |
434 | m'try it'; |
435 | s'first part'second part'; |
436 | s/yet another/tail here/; |
c2e66d9e |
437 | tr/A-Z/a-z/; |
b3ac6de7 |
438 | } |
439 | |
fdb7e2a2 |
440 | is($out, '_<foo>_'); |
441 | is($out1, '_<f\'o\\o>_'); |
442 | is($out2, "_<a\a>_foo_<,\,>_"); |
443 | is("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups |
b3ac6de7 |
444 | qq oups1 |
fdb7e2a2 |
445 | q second part q tail here s A-Z tr a-z tr"); |
446 | is("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); |
447 | is($res, 1); |
448 | is($a, "_<oups |
449 | >_"); |
450 | is($b, "_<oups1 |
451 | >_"); |
452 | is($c, "bareword"); |
b3ac6de7 |
453 | |
ee239bfe |
454 | { |
455 | package symbolic; # Primitive symbolic calculator |
456 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, |
457 | '=' => \&cpy, '++' => \&inc, '--' => \&dec; |
458 | |
459 | sub new { shift; bless ['n', @_] } |
460 | sub cpy { |
461 | my $self = shift; |
462 | bless [@$self], ref $self; |
463 | } |
464 | sub inc { $_[0] = bless ['++', $_[0], 1]; } |
465 | sub dec { $_[0] = bless ['--', $_[0], 1]; } |
466 | sub wrap { |
467 | my ($obj, $other, $inv, $meth) = @_; |
468 | if ($meth eq '++' or $meth eq '--') { |
469 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
470 | return $obj; |
471 | } |
472 | ($obj, $other) = ($other, $obj) if $inv; |
473 | bless [$meth, $obj, $other]; |
474 | } |
475 | sub str { |
476 | my ($meth, $a, $b) = @{+shift}; |
477 | $a = 'u' unless defined $a; |
478 | if (defined $b) { |
479 | "[$meth $a $b]"; |
480 | } else { |
481 | "[$meth $a]"; |
482 | } |
483 | } |
484 | my %subr = ( 'n' => sub {$_[0]} ); |
485 | foreach my $op (split " ", $overload::ops{with_assign}) { |
486 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; |
487 | } |
488 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); |
489 | foreach my $op (split " ", "@overload::ops{ @bins }") { |
490 | $subr{$op} = eval "sub {shift() $op shift()}"; |
491 | } |
492 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { |
493 | $subr{$op} = eval "sub {$op shift()}"; |
494 | } |
495 | $subr{'++'} = $subr{'+'}; |
496 | $subr{'--'} = $subr{'-'}; |
497 | |
498 | sub num { |
499 | my ($meth, $a, $b) = @{+shift}; |
500 | my $subr = $subr{$meth} |
501 | or die "Do not know how to ($meth) in symbolic"; |
502 | $a = $a->num if ref $a eq __PACKAGE__; |
503 | $b = $b->num if ref $b eq __PACKAGE__; |
504 | $subr->($a,$b); |
505 | } |
506 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } |
507 | sub FETCH { shift } |
508 | sub nop { } # Around a bug |
509 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } |
510 | sub STORE { |
511 | my $obj = shift; |
512 | $#$obj = 1; |
a1063b2d |
513 | $obj->[1] = shift; |
ee239bfe |
514 | } |
515 | } |
516 | |
517 | { |
518 | my $foo = new symbolic 11; |
519 | my $baz = $foo++; |
fdb7e2a2 |
520 | is((sprintf "%d", $foo), '12'); |
521 | is((sprintf "%d", $baz), '11'); |
ee239bfe |
522 | my $bar = $foo; |
523 | $baz = ++$foo; |
fdb7e2a2 |
524 | is((sprintf "%d", $foo), '13'); |
525 | is((sprintf "%d", $bar), '12'); |
526 | is((sprintf "%d", $baz), '13'); |
ee239bfe |
527 | my $ban = $foo; |
528 | $baz = ($foo += 1); |
fdb7e2a2 |
529 | is((sprintf "%d", $foo), '14'); |
530 | is((sprintf "%d", $bar), '12'); |
531 | is((sprintf "%d", $baz), '14'); |
532 | is((sprintf "%d", $ban), '13'); |
ee239bfe |
533 | $baz = 0; |
534 | $baz = $foo++; |
fdb7e2a2 |
535 | is((sprintf "%d", $foo), '15'); |
536 | is((sprintf "%d", $baz), '14'); |
537 | is("$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); |
ee239bfe |
538 | } |
539 | |
540 | { |
541 | my $iter = new symbolic 2; |
542 | my $side = new symbolic 1; |
543 | my $cnt = $iter; |
544 | |
545 | while ($cnt) { |
546 | $cnt = $cnt - 1; # The "simple" way |
547 | $side = (sqrt(1 + $side**2) - 1)/$side; |
548 | } |
549 | my $pi = $side*(2**($iter+2)); |
fdb7e2a2 |
550 | is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); |
551 | is((sprintf "%f", $pi), '3.182598'); |
ee239bfe |
552 | } |
553 | |
554 | { |
555 | my $iter = new symbolic 2; |
556 | my $side = new symbolic 1; |
557 | my $cnt = $iter; |
558 | |
559 | while ($cnt--) { |
560 | $side = (sqrt(1 + $side**2) - 1)/$side; |
561 | } |
562 | my $pi = $side*(2**($iter+2)); |
fdb7e2a2 |
563 | is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); |
564 | is((sprintf "%f", $pi), '3.182598'); |
ee239bfe |
565 | } |
566 | |
567 | { |
568 | my ($a, $b); |
569 | symbolic->vars($a, $b); |
570 | my $c = sqrt($a**2 + $b**2); |
571 | $a = 3; $b = 4; |
fdb7e2a2 |
572 | is((sprintf "%d", $c), '5'); |
ee239bfe |
573 | $a = 12; $b = 5; |
fdb7e2a2 |
574 | is((sprintf "%d", $c), '13'); |
ee239bfe |
575 | } |
576 | |
577 | { |
578 | package symbolic1; # Primitive symbolic calculator |
579 | # Mutator inc/dec |
580 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; |
581 | |
582 | sub new { shift; bless ['n', @_] } |
583 | sub cpy { |
584 | my $self = shift; |
585 | bless [@$self], ref $self; |
586 | } |
587 | sub wrap { |
588 | my ($obj, $other, $inv, $meth) = @_; |
589 | if ($meth eq '++' or $meth eq '--') { |
590 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
591 | return $obj; |
592 | } |
593 | ($obj, $other) = ($other, $obj) if $inv; |
594 | bless [$meth, $obj, $other]; |
595 | } |
596 | sub str { |
597 | my ($meth, $a, $b) = @{+shift}; |
598 | $a = 'u' unless defined $a; |
599 | if (defined $b) { |
600 | "[$meth $a $b]"; |
601 | } else { |
602 | "[$meth $a]"; |
603 | } |
604 | } |
605 | my %subr = ( 'n' => sub {$_[0]} ); |
606 | foreach my $op (split " ", $overload::ops{with_assign}) { |
607 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; |
608 | } |
609 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); |
610 | foreach my $op (split " ", "@overload::ops{ @bins }") { |
611 | $subr{$op} = eval "sub {shift() $op shift()}"; |
612 | } |
613 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { |
614 | $subr{$op} = eval "sub {$op shift()}"; |
615 | } |
616 | $subr{'++'} = $subr{'+'}; |
617 | $subr{'--'} = $subr{'-'}; |
618 | |
619 | sub num { |
620 | my ($meth, $a, $b) = @{+shift}; |
621 | my $subr = $subr{$meth} |
622 | or die "Do not know how to ($meth) in symbolic"; |
623 | $a = $a->num if ref $a eq __PACKAGE__; |
624 | $b = $b->num if ref $b eq __PACKAGE__; |
625 | $subr->($a,$b); |
626 | } |
627 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } |
628 | sub FETCH { shift } |
629 | sub nop { } # Around a bug |
630 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } |
631 | sub STORE { |
632 | my $obj = shift; |
633 | $#$obj = 1; |
a1063b2d |
634 | $obj->[1] = shift; |
ee239bfe |
635 | } |
636 | } |
637 | |
638 | { |
639 | my $foo = new symbolic1 11; |
640 | my $baz = $foo++; |
fdb7e2a2 |
641 | is((sprintf "%d", $foo), '12'); |
642 | is((sprintf "%d", $baz), '11'); |
ee239bfe |
643 | my $bar = $foo; |
644 | $baz = ++$foo; |
fdb7e2a2 |
645 | is((sprintf "%d", $foo), '13'); |
646 | is((sprintf "%d", $bar), '12'); |
647 | is((sprintf "%d", $baz), '13'); |
ee239bfe |
648 | my $ban = $foo; |
649 | $baz = ($foo += 1); |
fdb7e2a2 |
650 | is((sprintf "%d", $foo), '14'); |
651 | is((sprintf "%d", $bar), '12'); |
652 | is((sprintf "%d", $baz), '14'); |
653 | is((sprintf "%d", $ban), '13'); |
ee239bfe |
654 | $baz = 0; |
655 | $baz = $foo++; |
fdb7e2a2 |
656 | is((sprintf "%d", $foo), '15'); |
657 | is((sprintf "%d", $baz), '14'); |
658 | is("$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); |
ee239bfe |
659 | } |
660 | |
661 | { |
662 | my $iter = new symbolic1 2; |
663 | my $side = new symbolic1 1; |
664 | my $cnt = $iter; |
665 | |
666 | while ($cnt) { |
667 | $cnt = $cnt - 1; # The "simple" way |
668 | $side = (sqrt(1 + $side**2) - 1)/$side; |
669 | } |
670 | my $pi = $side*(2**($iter+2)); |
fdb7e2a2 |
671 | is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); |
672 | is((sprintf "%f", $pi), '3.182598'); |
ee239bfe |
673 | } |
674 | |
675 | { |
676 | my $iter = new symbolic1 2; |
677 | my $side = new symbolic1 1; |
678 | my $cnt = $iter; |
679 | |
680 | while ($cnt--) { |
681 | $side = (sqrt(1 + $side**2) - 1)/$side; |
682 | } |
683 | my $pi = $side*(2**($iter+2)); |
fdb7e2a2 |
684 | is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); |
685 | is((sprintf "%f", $pi), '3.182598'); |
ee239bfe |
686 | } |
687 | |
688 | { |
689 | my ($a, $b); |
690 | symbolic1->vars($a, $b); |
691 | my $c = sqrt($a**2 + $b**2); |
692 | $a = 3; $b = 4; |
fdb7e2a2 |
693 | is((sprintf "%d", $c), '5'); |
ee239bfe |
694 | $a = 12; $b = 5; |
fdb7e2a2 |
695 | is((sprintf "%d", $c), '13'); |
ee239bfe |
696 | } |
697 | |
698 | { |
699 | package two_face; # Scalars with separate string and |
700 | # numeric values. |
701 | sub new { my $p = shift; bless [@_], $p } |
702 | use overload '""' => \&str, '0+' => \&num, fallback => 1; |
703 | sub num {shift->[1]} |
704 | sub str {shift->[0]} |
705 | } |
706 | |
707 | { |
708 | my $seven = new two_face ("vii", 7); |
fdb7e2a2 |
709 | is((sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), |
ee239bfe |
710 | 'seven=vii, seven=7, eight=8'); |
fdb7e2a2 |
711 | is(scalar ($seven =~ /i/), '1'); |
ee239bfe |
712 | } |
b3ac6de7 |
713 | |
d0ecd44c |
714 | { |
715 | package sorting; |
716 | use overload 'cmp' => \∁ |
717 | sub new { my ($p, $v) = @_; bless \$v, $p } |
718 | sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } |
719 | } |
720 | { |
721 | my @arr = map sorting->new($_), 0..12; |
722 | my @sorted1 = sort @arr; |
723 | my @sorted2 = map $$_, @sorted1; |
7bf00c86 |
724 | is("@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'); |
d0ecd44c |
725 | } |
f5284f61 |
726 | { |
727 | package iterator; |
728 | use overload '<>' => \&iter; |
729 | sub new { my ($p, $v) = @_; bless \$v, $p } |
730 | sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } |
731 | } |
72b16652 |
732 | |
733 | # XXX iterator overload not intended to work with CORE::GLOBAL? |
734 | if (defined &CORE::GLOBAL::glob) { |
7bf00c86 |
735 | is('1', '1'); |
736 | is('1', '1'); |
737 | is('1', '1'); |
72b16652 |
738 | } |
739 | else { |
f5284f61 |
740 | my $iter = iterator->new(5); |
741 | my $acc = ''; |
742 | my $out; |
743 | $acc .= " $out" while $out = <${iter}>; |
7bf00c86 |
744 | is($acc, ' 5 4 3 2 1 0'); |
f5284f61 |
745 | $iter = iterator->new(5); |
7bf00c86 |
746 | is(scalar <${iter}>, '5'); |
f5284f61 |
747 | $acc = ''; |
b04ef359 |
748 | $acc .= " $out" while $out = <$iter>; |
7bf00c86 |
749 | is($acc, ' 4 3 2 1 0'); |
f5284f61 |
750 | } |
751 | { |
752 | package deref; |
753 | use overload '%{}' => \&hderef, '&{}' => \&cderef, |
754 | '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; |
755 | sub new { my ($p, $v) = @_; bless \$v, $p } |
756 | sub deref { |
757 | my ($self, $key) = (shift, shift); |
758 | my $class = ref $self; |
759 | bless $self, 'deref::dummy'; # Disable overloading of %{} |
760 | my $out = $self->{$key}; |
761 | bless $self, $class; # Restore overloading |
762 | $out; |
763 | } |
764 | sub hderef {shift->deref('h')} |
765 | sub aderef {shift->deref('a')} |
766 | sub cderef {shift->deref('c')} |
767 | sub gderef {shift->deref('g')} |
768 | sub sderef {shift->deref('s')} |
769 | } |
770 | { |
771 | my $deref = bless { h => { foo => 5 , fake => 23 }, |
772 | c => sub {return shift() + 34}, |
773 | 's' => \123, |
774 | a => [11..13], |
775 | g => \*srt, |
776 | }, 'deref'; |
777 | # Hash: |
778 | my @cont = sort %$deref; |
f70c35af |
779 | if ("\t" eq "\011") { # ascii |
7bf00c86 |
780 | is("@cont", '23 5 fake foo'); |
f70c35af |
781 | } |
782 | else { # ebcdic alpha-numeric sort order |
7bf00c86 |
783 | is("@cont", 'fake foo 23 5'); |
f70c35af |
784 | } |
f5284f61 |
785 | my @keys = sort keys %$deref; |
7bf00c86 |
786 | is("@keys", 'fake foo'); |
f5284f61 |
787 | my @val = sort values %$deref; |
7bf00c86 |
788 | is("@val", '23 5'); |
789 | is($deref->{foo}, 5); |
790 | is(defined $deref->{bar}, ''); |
f5284f61 |
791 | my $key; |
792 | @keys = (); |
793 | push @keys, $key while $key = each %$deref; |
794 | @keys = sort @keys; |
7bf00c86 |
795 | is("@keys", 'fake foo'); |
796 | is(exists $deref->{bar}, ''); |
797 | is(exists $deref->{foo}, 1); |
f5284f61 |
798 | # Code: |
7bf00c86 |
799 | is($deref->(5), 39); |
800 | is(&$deref(6), 40); |
f5284f61 |
801 | sub xxx_goto { goto &$deref } |
7bf00c86 |
802 | is(xxx_goto(7), 41); |
f5284f61 |
803 | my $srt = bless { c => sub {$b <=> $a} |
804 | }, 'deref'; |
805 | *srt = \&$srt; |
806 | my @sorted = sort srt 11, 2, 5, 1, 22; |
7bf00c86 |
807 | is("@sorted", '22 11 5 2 1'); |
f5284f61 |
808 | # Scalar |
7bf00c86 |
809 | is($$deref, 123); |
c6e96bcb |
810 | # Code |
811 | @sorted = sort $srt 11, 2, 5, 1, 22; |
7bf00c86 |
812 | is("@sorted", '22 11 5 2 1'); |
f5284f61 |
813 | # Array |
7bf00c86 |
814 | is("@$deref", '11 12 13'); |
815 | is($#$deref, '2'); |
f5284f61 |
816 | my $l = @$deref; |
7bf00c86 |
817 | is($l, 3); |
818 | is($deref->[2], '13'); |
f5284f61 |
819 | $l = pop @$deref; |
7bf00c86 |
820 | is($l, 13); |
f5284f61 |
821 | $l = 1; |
7bf00c86 |
822 | is($deref->[$l], '12'); |
f5284f61 |
823 | # Repeated dereference |
824 | my $double = bless { h => $deref, |
825 | }, 'deref'; |
7bf00c86 |
826 | is($double->{foo}, 5); |
f5284f61 |
827 | } |
828 | |
829 | { |
830 | package two_refs; |
831 | use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; |
832 | sub new { |
833 | my $p = shift; |
834 | bless \ [@_], $p; |
835 | } |
836 | sub gethash { |
837 | my %h; |
838 | my $self = shift; |
839 | tie %h, ref $self, $self; |
840 | \%h; |
841 | } |
842 | |
843 | sub TIEHASH { my $p = shift; bless \ shift, $p } |
844 | my %fields; |
845 | my $i = 0; |
846 | $fields{$_} = $i++ foreach qw{zero one two three}; |
847 | sub STORE { |
848 | my $self = ${shift()}; |
849 | my $key = $fields{shift()}; |
850 | defined $key or die "Out of band access"; |
851 | $$self->[$key] = shift; |
852 | } |
853 | sub FETCH { |
854 | my $self = ${shift()}; |
855 | my $key = $fields{shift()}; |
856 | defined $key or die "Out of band access"; |
857 | $$self->[$key]; |
858 | } |
859 | } |
860 | |
861 | my $bar = new two_refs 3,4,5,6; |
862 | $bar->[2] = 11; |
7bf00c86 |
863 | is($bar->{two}, 11); |
f5284f61 |
864 | $bar->{three} = 13; |
7bf00c86 |
865 | is($bar->[3], 13); |
f5284f61 |
866 | |
867 | { |
868 | package two_refs_o; |
869 | @ISA = ('two_refs'); |
870 | } |
871 | |
872 | $bar = new two_refs_o 3,4,5,6; |
873 | $bar->[2] = 11; |
7bf00c86 |
874 | is($bar->{two}, 11); |
f5284f61 |
875 | $bar->{three} = 13; |
7bf00c86 |
876 | is($bar->[3], 13); |
f5284f61 |
877 | |
878 | { |
879 | package two_refs1; |
880 | use overload '%{}' => sub { ${shift()}->[1] }, |
881 | '@{}' => sub { ${shift()}->[0] }; |
882 | sub new { |
883 | my $p = shift; |
884 | my $a = [@_]; |
885 | my %h; |
886 | tie %h, $p, $a; |
887 | bless \ [$a, \%h], $p; |
888 | } |
889 | sub gethash { |
890 | my %h; |
891 | my $self = shift; |
892 | tie %h, ref $self, $self; |
893 | \%h; |
894 | } |
895 | |
896 | sub TIEHASH { my $p = shift; bless \ shift, $p } |
897 | my %fields; |
898 | my $i = 0; |
899 | $fields{$_} = $i++ foreach qw{zero one two three}; |
900 | sub STORE { |
901 | my $a = ${shift()}; |
902 | my $key = $fields{shift()}; |
903 | defined $key or die "Out of band access"; |
904 | $a->[$key] = shift; |
905 | } |
906 | sub FETCH { |
907 | my $a = ${shift()}; |
908 | my $key = $fields{shift()}; |
909 | defined $key or die "Out of band access"; |
910 | $a->[$key]; |
911 | } |
912 | } |
913 | |
914 | $bar = new two_refs_o 3,4,5,6; |
915 | $bar->[2] = 11; |
7bf00c86 |
916 | is($bar->{two}, 11); |
f5284f61 |
917 | $bar->{three} = 13; |
7bf00c86 |
918 | is($bar->[3], 13); |
f5284f61 |
919 | |
920 | { |
921 | package two_refs1_o; |
922 | @ISA = ('two_refs1'); |
923 | } |
924 | |
925 | $bar = new two_refs1_o 3,4,5,6; |
926 | $bar->[2] = 11; |
7bf00c86 |
927 | is($bar->{two}, 11); |
f5284f61 |
928 | $bar->{three} = 13; |
7bf00c86 |
929 | is($bar->[3], 13); |
f5284f61 |
930 | |
fe7ac86a |
931 | { |
932 | package B; |
933 | use overload bool => sub { ${+shift} }; |
934 | } |
935 | |
936 | my $aaa; |
937 | { my $bbbb = 0; $aaa = bless \$bbbb, B } |
938 | |
7bf00c86 |
939 | is !$aaa, 1; |
fe7ac86a |
940 | |
941 | unless ($aaa) { |
7bf00c86 |
942 | pass(); |
fe7ac86a |
943 | } else { |
7bf00c86 |
944 | fail(); |
fe7ac86a |
945 | } |
946 | |
1426bbf4 |
947 | # check that overload isn't done twice by join |
948 | { my $c = 0; |
949 | package Join; |
950 | use overload '""' => sub { $c++ }; |
951 | my $x = join '', bless([]), 'pq', bless([]); |
7bf00c86 |
952 | main::is $x, '0pq1'; |
1426bbf4 |
953 | }; |
fe7ac86a |
954 | |
4498a751 |
955 | # Test module-specific warning |
956 | { |
957 | # check the Odd number of arguments for overload::constant warning |
958 | my $a = "" ; |
0a911d86 |
959 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 |
960 | $x = eval ' overload::constant "integer" ; ' ; |
7bf00c86 |
961 | is($a, ""); |
4498a751 |
962 | use warnings 'overload' ; |
963 | $x = eval ' overload::constant "integer" ; ' ; |
7bf00c86 |
964 | like($a, qr/^Odd number of arguments for overload::constant at/); |
4498a751 |
965 | } |
966 | |
967 | { |
968 | # check the `$_[0]' is not an overloadable type warning |
969 | my $a = "" ; |
0a911d86 |
970 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 |
971 | $x = eval ' overload::constant "fred" => sub {} ; ' ; |
7bf00c86 |
972 | is($a, ""); |
4498a751 |
973 | use warnings 'overload' ; |
974 | $x = eval ' overload::constant "fred" => sub {} ; ' ; |
7bf00c86 |
975 | like($a, qr/^`fred' is not an overloadable type at/); |
4498a751 |
976 | } |
977 | |
978 | { |
979 | # check the `$_[1]' is not a code reference warning |
980 | my $a = "" ; |
0a911d86 |
981 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
4498a751 |
982 | $x = eval ' overload::constant "integer" => 1; ' ; |
7bf00c86 |
983 | is($a, ""); |
4498a751 |
984 | use warnings 'overload' ; |
985 | $x = eval ' overload::constant "integer" => 1; ' ; |
7bf00c86 |
986 | like($a, qr/^`1' is not a code reference at/); |
4498a751 |
987 | } |
988 | |
78f67eb5 |
989 | { |
990 | my $c = 0; |
991 | package ov_int1; |
992 | use overload '""' => sub { 3+shift->[0] }, |
993 | '0+' => sub { 10+shift->[0] }, |
994 | 'int' => sub { 100+shift->[0] }; |
995 | sub new {my $p = shift; bless [shift], $p} |
996 | |
997 | package ov_int2; |
998 | use overload '""' => sub { 5+shift->[0] }, |
999 | '0+' => sub { 30+shift->[0] }, |
1000 | 'int' => sub { 'ov_int1'->new(1000+shift->[0]) }; |
1001 | sub new {my $p = shift; bless [shift], $p} |
1002 | |
1003 | package noov_int; |
1004 | use overload '""' => sub { 2+shift->[0] }, |
1005 | '0+' => sub { 9+shift->[0] }; |
1006 | sub new {my $p = shift; bless [shift], $p} |
1007 | |
1008 | package main; |
1009 | |
1010 | my $x = new noov_int 11; |
1011 | my $int_x = int $x; |
7bf00c86 |
1012 | main::is("$int_x", 20); |
78f67eb5 |
1013 | $x = new ov_int1 31; |
1014 | $int_x = int $x; |
7bf00c86 |
1015 | main::is("$int_x", 131); |
78f67eb5 |
1016 | $x = new ov_int2 51; |
1017 | $int_x = int $x; |
7bf00c86 |
1018 | main::is("$int_x", 1054); |
78f67eb5 |
1019 | } |
1020 | |
1554e226 |
1021 | # make sure that we don't inifinitely recurse |
1022 | { |
1023 | my $c = 0; |
1024 | package Recurse; |
1025 | use overload '""' => sub { shift }, |
1026 | '0+' => sub { shift }, |
1027 | 'bool' => sub { shift }, |
1028 | fallback => 1; |
1029 | my $x = bless([]); |
7bf00c86 |
1030 | # For some reason beyond me these have to be oks rather than likes. |
1031 | main::ok("$x" =~ /Recurse=ARRAY/); |
1032 | main::ok($x); |
1033 | main::ok($x+0 =~ qr/Recurse=ARRAY/); |
11e3e2e4 |
1034 | } |
78f67eb5 |
1035 | |
1dc13c17 |
1036 | # BugID 20010422.003 |
1037 | package Foo; |
1038 | |
1039 | use overload |
1040 | 'bool' => sub { return !$_[0]->is_zero() || undef; } |
1041 | ; |
1042 | |
1043 | sub is_zero |
1044 | { |
1045 | my $self = shift; |
1046 | return $self->{var} == 0; |
1047 | } |
1048 | |
1049 | sub new |
1050 | { |
1051 | my $class = shift; |
1052 | my $self = {}; |
1053 | $self->{var} = shift; |
1054 | bless $self,$class; |
1055 | } |
1056 | |
1057 | package main; |
1058 | |
1059 | use strict; |
1060 | |
1061 | my $r = Foo->new(8); |
1062 | $r = Foo->new(0); |
78f67eb5 |
1063 | |
11e3e2e4 |
1064 | is(($r || 0), 0); |
1554e226 |
1065 | |
6050d10e |
1066 | package utf8_o; |
1067 | |
1068 | use overload |
1069 | '""' => sub { return $_[0]->{var}; } |
1070 | ; |
1071 | |
1072 | sub new |
1073 | { |
1074 | my $class = shift; |
1075 | my $self = {}; |
1076 | $self->{var} = shift; |
1077 | bless $self,$class; |
1078 | } |
1079 | |
1080 | package main; |
1081 | |
1082 | |
1083 | my $utfvar = new utf8_o 200.2.1; |
11e3e2e4 |
1084 | is("$utfvar", 200.2.1); # 223 - stringify |
1085 | is("a$utfvar", "a".200.2.1); # 224 - overload via sv_2pv_flags |
6050d10e |
1086 | |
446eaa42 |
1087 | # 225..227 -- more %{} tests. Hangs in 5.6.0, okay in later releases. |
41cb1005 |
1088 | # Basically this example implements strong encapsulation: if Hderef::import() |
1089 | # were to eval the overload code in the caller's namespace, the privatisation |
1090 | # would be quite transparent. |
1091 | package Hderef; |
1092 | use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" }; |
1093 | package Foo; |
1094 | @Foo::ISA = 'Hderef'; |
1095 | sub new { bless {}, shift } |
1096 | sub xet { @_ == 2 ? $_[0]->{$_[1]} : |
1097 | @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef } |
1098 | package main; |
1099 | my $a = Foo->new; |
1100 | $a->xet('b', 42); |
11e3e2e4 |
1101 | is ($a->xet('b'), 42); |
1102 | ok (!defined eval { $a->{b} }); |
1103 | like ($@, qr/zap/); |
41cb1005 |
1104 | |
29ddfe35 |
1105 | { |
1106 | package t229; |
1107 | use overload '=' => sub { 42 }, |
1108 | '++' => sub { my $x = ${$_[0]}; $_[0] }; |
1109 | sub new { my $x = 42; bless \$x } |
1110 | |
1111 | my $warn; |
1112 | { |
1113 | local $SIG{__WARN__} = sub { $warn++ }; |
1114 | my $x = t229->new; |
1115 | my $y = $x; |
1116 | eval { $y++ }; |
1117 | } |
11e3e2e4 |
1118 | main::ok (!$warn); |
61f33854 |
1119 | } |
1120 | |
1121 | { |
1122 | my ($int, $out1, $out2); |
1123 | { |
1124 | BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; } |
1125 | $out1 = 0; |
1126 | $out2 = 1; |
1127 | } |
11e3e2e4 |
1128 | is($int, 2, "#24313"); # 230 |
1129 | is($out1, 17, "#24313"); # 231 |
1130 | is($out2, 17, "#24313"); # 232 |
29ddfe35 |
1131 | } |
1132 | |
0bdaccee |
1133 | { |
1134 | package Numify; |
1135 | use overload (qw(0+ numify fallback 1)); |
1136 | |
1137 | sub new { |
1138 | my $val = $_[1]; |
1139 | bless \$val, $_[0]; |
1140 | } |
1141 | |
1142 | sub numify { ${$_[0]} } |
1143 | } |
1144 | |
d411a6a9 |
1145 | { |
1146 | package perl31793; |
1b1d102f |
1147 | use overload cmp => sub { 0 }; |
1148 | package perl31793_fb; |
76c43448 |
1149 | use overload cmp => sub { 0 }, fallback => 1; |
d411a6a9 |
1150 | package main; |
1151 | my $o = bless [], 'perl31793'; |
1b1d102f |
1152 | my $of = bless [], 'perl31793_fb'; |
d411a6a9 |
1153 | my $no = bless [], 'no_overload'; |
11e3e2e4 |
1154 | like(overload::StrVal(\"scalar"), qr/^SCALAR\(0x[0-9a-f]+\)$/); |
1155 | like(overload::StrVal([]), qr/^ARRAY\(0x[0-9a-f]+\)$/); |
1156 | like(overload::StrVal({}), qr/^HASH\(0x[0-9a-f]+\)$/); |
1157 | like(overload::StrVal(sub{1}), qr/^CODE\(0x[0-9a-f]+\)$/); |
1158 | like(overload::StrVal(\*GLOB), qr/^GLOB\(0x[0-9a-f]+\)$/); |
1159 | like(overload::StrVal(\$o), qr/^REF\(0x[0-9a-f]+\)$/); |
1160 | like(overload::StrVal(qr/a/), qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/); |
1161 | like(overload::StrVal($o), qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/); |
1162 | like(overload::StrVal($of), qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/); |
1163 | like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/); |
d411a6a9 |
1164 | } |
1165 | |
0bdaccee |
1166 | # These are all check that overloaded values rather than reference addressess |
1167 | # are what is getting tested. |
1168 | my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; |
1169 | my ($ein, $zwei) = (1, 2); |
1170 | |
1171 | my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); |
1172 | foreach my $op (qw(<=> == != < <= > >=)) { |
1173 | foreach my $l (keys %map) { |
1174 | foreach my $r (keys %map) { |
1175 | my $ocode = "\$$l $op \$$r"; |
1176 | my $rcode = "$map{$l} $op $map{$r}"; |
1177 | |
1178 | my $got = eval $ocode; |
1179 | die if $@; |
1180 | my $expect = eval $rcode; |
1181 | die if $@; |
11e3e2e4 |
1182 | is ($got, $expect, $ocode) or print "# $rcode\n"; |
0bdaccee |
1183 | } |
1184 | } |
1185 | } |
131b3ad0 |
1186 | { |
1187 | # check that overloading works in regexes |
1188 | { |
1189 | package Foo493; |
1190 | use overload |
1191 | '""' => sub { "^$_[0][0]\$" }, |
1192 | '.' => sub { |
1193 | bless [ |
1194 | $_[2] |
1195 | ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0] |
1196 | : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1]) |
1197 | ], 'Foo493' |
1198 | }; |
1199 | } |
1200 | |
1201 | my $a = bless [ "a" ], 'Foo493'; |
11e3e2e4 |
1202 | like('a', qr/$a/); |
1203 | like('x:a', qr/x$a/); |
1204 | like('x:a:=', qr/x$a=$/); |
1205 | like('x:a:a:=', qr/x$a$a=$/); |
131b3ad0 |
1206 | |
1207 | } |
1208 | |
705c898c |
1209 | { |
1210 | my $twenty_three = 23; |
1211 | # Check that constant overloading propagates into evals |
1212 | BEGIN { overload::constant integer => sub { 23 } } |
11e3e2e4 |
1213 | is(eval "17", $twenty_three); |
705c898c |
1214 | } |