This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stray s/foo/PL_foo/
[perl5.git] / t / pragma / overload.t
CommitLineData
8ebc5c01
PP
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
8use Config;
9
10package Oscalar;
11use overload (
12 # Anonymous subroutines:
13'+' => sub {new Oscalar $ {$_[0]}+$_[1]},
14'-' => sub {new Oscalar
15 $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
16'<=>' => sub {new Oscalar
17 $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
18'cmp' => sub {new Oscalar
19 $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
20'*' => sub {new Oscalar ${$_[0]}*$_[1]},
21'/' => sub {new Oscalar
22 $_[2]? $_[1]/${$_[0]} :
23 ${$_[0]}/$_[1]},
24'%' => sub {new Oscalar
25 $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
26'**' => sub {new Oscalar
27 $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
28
29qw(
30"" stringify
310+ numify) # Order of arguments unsignificant
32);
33
34sub new {
35 my $foo = $_[1];
36 bless \$foo, $_[0];
37}
38
39sub stringify { "${$_[0]}" }
40sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
41 # comparing to direct compilation based on
42 # stringify
43
44package main;
45
46$test = 0;
47$| = 1;
48print "1..",&last,"\n";
49
50sub test {
b3ac6de7
IZ
51 $test++;
52 if (@_ > 1) {
53 if ($_[0] eq $_[1]) {
54 print "ok $test\n";
55 } else {
56 print "not ok $test: '$_[0]' ne '$_[1]'\n";
57 }
58 } else {
59 if (shift) {
60 print "ok $test\n";
61 } else {
62 print "not ok $test\n";
63 }
64 }
8ebc5c01
PP
65}
66
67$a = new Oscalar "087";
68$b= "$a";
69
70# All test numbers in comments are off by 1.
71# So much for hard-wiring them in :-) To fix this:
72test(1); # 1
73
74test ($b eq $a); # 2
75test ($b eq "087"); # 3
76test (ref $a eq "Oscalar"); # 4
77test ($a eq $a); # 5
78test ($a eq "087"); # 6
79
80$c = $a + 7;
81
82test (ref $c eq "Oscalar"); # 7
83test (!($c eq $a)); # 8
84test ($c eq "94"); # 9
85
86$b=$a;
87
88test (ref $a eq "Oscalar"); # 10
89
90$b++;
91
92test (ref $b eq "Oscalar"); # 11
93test ( $a eq "087"); # 12
94test ( $b eq "88"); # 13
95test (ref $a eq "Oscalar"); # 14
96
97$c=$b;
98$c-=$a;
99
100test (ref $c eq "Oscalar"); # 15
101test ( $a eq "087"); # 16
102test ( $c eq "1"); # 17
103test (ref $a eq "Oscalar"); # 18
104
105$b=1;
106$b+=$a;
107
108test (ref $b eq "Oscalar"); # 19
109test ( $a eq "087"); # 20
110test ( $b eq "88"); # 21
111test (ref $a eq "Oscalar"); # 22
112
113eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
114
115$b=$a;
116
117test (ref $a eq "Oscalar"); # 23
118
119$b++;
120
121test (ref $b eq "Oscalar"); # 24
122test ( $a eq "087"); # 25
123test ( $b eq "88"); # 26
124test (ref $a eq "Oscalar"); # 27
125
126package Oscalar;
127$dummy=bless \$dummy; # Now cache of method should be reloaded
128package main;
129
130$b=$a;
131$b++;
132
133test (ref $b eq "Oscalar"); # 28
134test ( $a eq "087"); # 29
135test ( $b eq "88"); # 30
136test (ref $a eq "Oscalar"); # 31
137
138
139eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
140
141$b=$a;
142
143test (ref $a eq "Oscalar"); # 32
144
145$b++;
146
147test (ref $b eq "Oscalar"); # 33
148test ( $a eq "087"); # 34
149test ( $b eq "88"); # 35
150test (ref $a eq "Oscalar"); # 36
151
152package Oscalar;
153$dummy=bless \$dummy; # Now cache of method should be reloaded
154package main;
155
156$b++;
157
158test (ref $b eq "Oscalar"); # 37
159test ( $a eq "087"); # 38
160test ( $b eq "90"); # 39
161test (ref $a eq "Oscalar"); # 40
162
163$b=$a;
164$b++;
165
166test (ref $b eq "Oscalar"); # 41
167test ( $a eq "087"); # 42
168test ( $b eq "89"); # 43
169test (ref $a eq "Oscalar"); # 44
170
171
172test ($b? 1:0); # 45
173
174eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
175 package Oscalar;
176 local $new=$ {$_[0]};
177 bless \$new } ) ];
178
179$b=new Oscalar "$a";
180
181test (ref $b eq "Oscalar"); # 46
182test ( $a eq "087"); # 47
183test ( $b eq "087"); # 48
184test (ref $a eq "Oscalar"); # 49
185
186$b++;
187
188test (ref $b eq "Oscalar"); # 50
189test ( $a eq "087"); # 51
190test ( $b eq "89"); # 52
191test (ref $a eq "Oscalar"); # 53
192test ($copies == 0); # 54
193
194$b+=1;
195
196test (ref $b eq "Oscalar"); # 55
197test ( $a eq "087"); # 56
198test ( $b eq "90"); # 57
199test (ref $a eq "Oscalar"); # 58
200test ($copies == 0); # 59
201
202$b=$a;
203$b+=1;
204
205test (ref $b eq "Oscalar"); # 60
206test ( $a eq "087"); # 61
207test ( $b eq "88"); # 62
208test (ref $a eq "Oscalar"); # 63
209test ($copies == 0); # 64
210
211$b=$a;
212$b++;
213
214test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
215test ( $a eq "087"); # 66
216test ( $b eq "89"); # 67
217test (ref $a eq "Oscalar"); # 68
218test ($copies == 1); # 69
219
220eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
221 $_[0] } ) ];
222$c=new Oscalar; # Cause rehash
223
224$b=$a;
225$b+=1;
226
227test (ref $b eq "Oscalar"); # 70
228test ( $a eq "087"); # 71
229test ( $b eq "90"); # 72
230test (ref $a eq "Oscalar"); # 73
231test ($copies == 2); # 74
232
233$b+=$b;
234
235test (ref $b eq "Oscalar"); # 75
236test ( $b eq "360"); # 76
237test ($copies == 2); # 77
238$b=-$b;
239
240test (ref $b eq "Oscalar"); # 78
241test ( $b eq "-360"); # 79
242test ($copies == 2); # 80
243
244$b=abs($b);
245
246test (ref $b eq "Oscalar"); # 81
247test ( $b eq "360"); # 82
248test ($copies == 2); # 83
249
250$b=abs($b);
251
252test (ref $b eq "Oscalar"); # 84
253test ( $b eq "360"); # 85
254test ($copies == 2); # 86
255
256eval q[package Oscalar;
257 use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
258 : "_.${$_[0]}._" x $_[1])}) ];
259
260$a=new Oscalar "yy";
261$a x= 3;
262test ($a eq "_.yy.__.yy.__.yy._"); # 87
263
264eval q[package Oscalar;
265 use overload ('.' => sub {new Oscalar ( $_[2] ?
266 "_.$_[1].__.$ {$_[0]}._"
267 : "_.$ {$_[0]}.__.$_[1]._")}) ];
268
269$a=new Oscalar "xx";
270
271test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
272
273# Check inheritance of overloading;
274{
275 package OscalarI;
276 @ISA = 'Oscalar';
277}
278
279$aI = new OscalarI "$a";
280test (ref $aI eq "OscalarI"); # 89
281test ("$aI" eq "xx"); # 90
282test ($aI eq "xx"); # 91
283test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92
284
285# Here we test blessing to a package updates hash
286
287eval "package Oscalar; no overload '.'";
288
289test ("b${a}" eq "_.b.__.xx._"); # 93
290$x="1";
291bless \$x, Oscalar;
292test ("b${a}c" eq "bxxc"); # 94
293new Oscalar 1;
294test ("b${a}c" eq "bxxc"); # 95
295
296# Negative overloading:
297
298$na = eval { ~$a };
299test($@ =~ /no method found/); # 96
300
301# Check AUTOLOADING:
302
303*Oscalar::AUTOLOAD =
304 sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
305 goto &{"Oscalar::$AUTOLOAD"}};
306
44a8e56a 307eval "package Oscalar; sub comple; use overload '~' => 'comple'";
8ebc5c01
PP
308
309$na = eval { ~$a }; # Hash was not updated
310test($@ =~ /no method found/); # 97
311
312bless \$x, Oscalar;
313
314$na = eval { ~$a }; # Hash updated
44a8e56a 315warn "`$na', $@" if $@;
8ebc5c01
PP
316test !$@; # 98
317test($na eq '_!_xx_!_'); # 99
318
319$na = 0;
320
321$na = eval { ~$aI }; # Hash was not updated
322test($@ =~ /no method found/); # 100
323
324bless \$x, OscalarI;
325
326$na = eval { ~$aI };
327print $@;
328
329test !$@; # 101
330test($na eq '_!_xx_!_'); # 102
331
44a8e56a 332eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
8ebc5c01
PP
333
334$na = eval { $aI >> 1 }; # Hash was not updated
335test($@ =~ /no method found/); # 103
336
337bless \$x, OscalarI;
338
339$na = 0;
340
341$na = eval { $aI >> 1 };
342print $@;
343
344test !$@; # 104
345test($na eq '_!_xx_!_'); # 105
346
44a8e56a 347# warn overload::Method($a, '0+'), "\n";
8ebc5c01
PP
348test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
349test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
350test (overload::Overloaded($aI)); # 108
351test (!overload::Overloaded('overload')); # 109
352
353test (! defined overload::Method($aI, '<<')); # 110
354test (! defined overload::Method($a, '<')); # 111
355
356test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
357test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
358
44a8e56a
PP
359# Check overloading by methods (specified deep in the ISA tree).
360{
361 package OscalarII;
362 @ISA = 'OscalarI';
363 sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
364 eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
365}
366
367$aaII = "087";
368$aII = \$aaII;
369bless $aII, 'OscalarII';
370bless \$fake, 'OscalarI'; # update the hash
371test(($aI | 3) eq '_<<_xx_<<_'); # 114
372# warn $aII << 3;
373test(($aII << 3) eq '_<<_087_<<_'); # 115
374
b3ac6de7
IZ
375{
376 BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
377 $out = 2**10;
378}
379test($int, 9); # 116
380test($out, 1024); # 117
381
382$foo = 'foo';
383$foo1 = 'f\'o\\o';
384{
385 BEGIN { $q = $qr = 7;
386 overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift},
387 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; }
388 $out = 'foo';
389 $out1 = 'f\'o\\o';
390 $out2 = "a\a$foo,\,";
391 /b\b$foo.\./;
392}
393
394test($out, 'foo'); # 118
395test($out, $foo); # 119
396test($out1, 'f\'o\\o'); # 120
397test($out1, $foo1); # 121
398test($out2, "a\afoo,\,"); # 122
399test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
400test($q, 11); # 124
401test("@qr", "b\\b qq .\\. qq"); # 125
402test($qr, 9); # 126
403
404{
405 $_ = '!<b>!foo!<-.>!';
406 BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
407 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
408 $out = 'foo';
409 $out1 = 'f\'o\\o';
410 $out2 = "a\a$foo,\,";
411 $res = /b\b$foo.\./;
412 $a = <<EOF;
413oups
414EOF
415 $b = <<'EOF';
416oups1
417EOF
418 $c = bareword;
419 m'try it';
420 s'first part'second part';
421 s/yet another/tail here/;
422 tr/z-Z/z-Z/;
423}
424
425test($out, '_<foo>_'); # 117
426test($out1, '_<f\'o\\o>_'); # 128
427test($out2, "_<a\a>_foo_<,\,>_"); # 129
428test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
429 qq oups1
430 q second part q tail here s z-Z tr z-Z tr"); # 130
431test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131
432test($res, 1); # 132
433test($a, "_<oups
434>_"); # 133
435test($b, "_<oups1
436>_"); # 134
437test($c, "bareword"); # 135
438
439
8ebc5c01 440# Last test is:
b3ac6de7 441sub last {135}