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