t/pragma/overload.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use Config;
   9
  10 package Oscalar;
  11 use 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
  29 qw(
  30 ""      stringify
  31 0+      numify)                 # Order of arguments unsignificant
  32 );
  33
  34 sub new {
  35   my $foo = $_[1];
  36   bless \$foo, $_[0];
  37 }
  38
  39 sub stringify { "${$_[0]}" }
  40 sub numify { 0 + "${$_[0]}" }   # Not needed, additional overhead
  41                                 # comparing to direct compilation based on
  42                                 # stringify
  43
  44 package main;
  45
  46 $test = 0;
  47 $| = 1;
  48 print "1..",&last,"\n";
  49
  50 sub test {
  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   }
  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:
  72 test(1);                        # 1
  73
  74 test ($b eq $a);                # 2
  75 test ($b eq "087");             # 3
  76 test (ref $a eq "Oscalar");     # 4
  77 test ($a eq $a);                # 5
  78 test ($a eq "087");             # 6
  79
  80 $c = $a + 7;
  81
  82 test (ref $c eq "Oscalar");     # 7
  83 test (!($c eq $a));             # 8
  84 test ($c eq "94");              # 9
  85
  86 $b=$a;
  87
  88 test (ref $a eq "Oscalar");     # 10
  89
  90 $b++;
  91
  92 test (ref $b eq "Oscalar");     # 11
  93 test ( $a eq "087");            # 12
  94 test ( $b eq "88");             # 13
  95 test (ref $a eq "Oscalar");     # 14
  96
  97 $c=$b;
  98 $c-=$a;
  99
 100 test (ref $c eq "Oscalar");     # 15
 101 test ( $a eq "087");            # 16
 102 test ( $c eq "1");              # 17
 103 test (ref $a eq "Oscalar");     # 18
 104
 105 $b=1;
 106 $b+=$a;
 107
 108 test (ref $b eq "Oscalar");     # 19
 109 test ( $a eq "087");            # 20
 110 test ( $b eq "88");             # 21
 111 test (ref $a eq "Oscalar");     # 22
 112
 113 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
 114
 115 $b=$a;
 116
 117 test (ref $a eq "Oscalar");     # 23
 118
 119 $b++;
 120
 121 test (ref $b eq "Oscalar");     # 24
 122 test ( $a eq "087");            # 25
 123 test ( $b eq "88");             # 26
 124 test (ref $a eq "Oscalar");     # 27
 125
 126 package Oscalar;
 127 $dummy=bless \$dummy;           # Now cache of method should be reloaded
 128 package main;
 129
 130 $b=$a;
 131 $b++;
 132
 133 test (ref $b eq "Oscalar");     # 28
 134 test ( $a eq "087");            # 29
 135 test ( $b eq "88");             # 30
 136 test (ref $a eq "Oscalar");     # 31
 137
 138
 139 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
 140
 141 $b=$a;
 142
 143 test (ref $a eq "Oscalar");     # 32
 144
 145 $b++;
 146
 147 test (ref $b eq "Oscalar");     # 33
 148 test ( $a eq "087");            # 34
 149 test ( $b eq "88");             # 35
 150 test (ref $a eq "Oscalar");     # 36
 151
 152 package Oscalar;
 153 $dummy=bless \$dummy;           # Now cache of method should be reloaded
 154 package main;
 155
 156 $b++;
 157
 158 test (ref $b eq "Oscalar");     # 37
 159 test ( $a eq "087");            # 38
 160 test ( $b eq "90");             # 39
 161 test (ref $a eq "Oscalar");     # 40
 162
 163 $b=$a;
 164 $b++;
 165
 166 test (ref $b eq "Oscalar");     # 41
 167 test ( $a eq "087");            # 42
 168 test ( $b eq "89");             # 43
 169 test (ref $a eq "Oscalar");     # 44
 170
 171
 172 test ($b? 1:0);                 # 45
 173
 174 eval 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
 181 test (ref $b eq "Oscalar");     # 46
 182 test ( $a eq "087");            # 47
 183 test ( $b eq "087");            # 48
 184 test (ref $a eq "Oscalar");     # 49
 185
 186 $b++;
 187
 188 test (ref $b eq "Oscalar");     # 50
 189 test ( $a eq "087");            # 51
 190 test ( $b eq "89");             # 52
 191 test (ref $a eq "Oscalar");     # 53
 192 test ($copies == 0);            # 54
 193
 194 $b+=1;
 195
 196 test (ref $b eq "Oscalar");     # 55
 197 test ( $a eq "087");            # 56
 198 test ( $b eq "90");             # 57
 199 test (ref $a eq "Oscalar");     # 58
 200 test ($copies == 0);            # 59
 201
 202 $b=$a;
 203 $b+=1;
 204
 205 test (ref $b eq "Oscalar");     # 60
 206 test ( $a eq "087");            # 61
 207 test ( $b eq "88");             # 62
 208 test (ref $a eq "Oscalar");     # 63
 209 test ($copies == 0);            # 64
 210
 211 $b=$a;
 212 $b++;
 213
 214 test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
 215 test ( $a eq "087");            # 66
 216 test ( $b eq "89");             # 67
 217 test (ref $a eq "Oscalar");     # 68
 218 test ($copies == 1);            # 69
 219
 220 eval 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
 227 test (ref $b eq "Oscalar");     # 70
 228 test ( $a eq "087");            # 71
 229 test ( $b eq "90");             # 72
 230 test (ref $a eq "Oscalar");     # 73
 231 test ($copies == 2);            # 74
 232
 233 $b+=$b;
 234
 235 test (ref $b eq "Oscalar");     # 75
 236 test ( $b eq "360");            # 76
 237 test ($copies == 2);            # 77
 238 $b=-$b;
 239
 240 test (ref $b eq "Oscalar");     # 78
 241 test ( $b eq "-360");           # 79
 242 test ($copies == 2);            # 80
 243
 244 $b=abs($b);
 245
 246 test (ref $b eq "Oscalar");     # 81
 247 test ( $b eq "360");            # 82
 248 test ($copies == 2);            # 83
 249
 250 $b=abs($b);
 251
 252 test (ref $b eq "Oscalar");     # 84
 253 test ( $b eq "360");            # 85
 254 test ($copies == 2);            # 86
 255
 256 eval 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;
 262 test ($a eq "_.yy.__.yy.__.yy._"); # 87
 263
 264 eval q[package Oscalar;
 265        use overload ('.' => sub {new Oscalar ( $_[2] ?
 266                                               "_.$_[1].__.$ {$_[0]}._"
 267                                               : "_.$ {$_[0]}.__.$_[1]._")}) ];
 268
 269 $a=new Oscalar "xx";
 270
 271 test ("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";
 280 test (ref $aI eq "OscalarI");   # 89
 281 test ("$aI" eq "xx");           # 90
 282 test ($aI eq "xx");             # 91
 283 test ("b${aI}c" eq "_._.b.__.xx._.__.c._");             # 92
 284
 285 # Here we test blessing to a package updates hash
 286
 287 eval "package Oscalar; no overload '.'";
 288
 289 test ("b${a}" eq "_.b.__.xx._"); # 93
 290 $x="1";
 291 bless \$x, Oscalar;
 292 test ("b${a}c" eq "bxxc");      # 94
 293 new Oscalar 1;
 294 test ("b${a}c" eq "bxxc");      # 95
 295
 296 # Negative overloading:
 297
 298 $na = eval { ~$a };
 299 test($@ =~ /no method found/);  # 96
 300
 301 # Check AUTOLOADING:
 302
 303 *Oscalar::AUTOLOAD =
 304   sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
 305         goto &{"Oscalar::$AUTOLOAD"}};
 306
 307 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
 308
 309 $na = eval { ~$a };             # Hash was not updated
 310 test($@ =~ /no method found/);  # 97
 311
 312 bless \$x, Oscalar;
 313
 314 $na = eval { ~$a };             # Hash updated
 315 warn "`$na', $@" if $@;
 316 test !$@;                       # 98
 317 test($na eq '_!_xx_!_');        # 99
 318
 319 $na = 0;
 320
 321 $na = eval { ~$aI };            # Hash was not updated
 322 test($@ =~ /no method found/);  # 100
 323
 324 bless \$x, OscalarI;
 325
 326 $na = eval { ~$aI };
 327 print $@;
 328
 329 test !$@;                       # 101
 330 test($na eq '_!_xx_!_');        # 102
 331
 332 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
 333
 334 $na = eval { $aI >> 1 };        # Hash was not updated
 335 test($@ =~ /no method found/);  # 103
 336
 337 bless \$x, OscalarI;
 338
 339 $na = 0;
 340
 341 $na = eval { $aI >> 1 };
 342 print $@;
 343
 344 test !$@;                       # 104
 345 test($na eq '_!_xx_!_');        # 105
 346
 347 # warn overload::Method($a, '0+'), "\n";
 348 test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
 349 test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
 350 test (overload::Overloaded($aI)); # 108
 351 test (!overload::Overloaded('overload')); # 109
 352
 353 test (! defined overload::Method($aI, '<<')); # 110
 354 test (! defined overload::Method($a, '<')); # 111
 355
 356 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
 357 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
 358
 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;
 369 bless $aII, 'OscalarII';
 370 bless \$fake, 'OscalarI';               # update the hash
 371 test(($aI | 3) eq '_<<_xx_<<_');        # 114
 372 # warn $aII << 3;
 373 test(($aII << 3) eq '_<<_087_<<_');     # 115
 374
 375 {
 376   BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
 377   $out = 2**10;
 378 }
 379 test($int, 9);          # 116
 380 test($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
 394 test($out, 'foo');              # 118
 395 test($out, $foo);               # 119
 396 test($out1, 'f\'o\\o');         # 120
 397 test($out1, $foo1);             # 121
 398 test($out2, "a\afoo,\,");       # 122
 399 test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
 400 test($q, 11);                   # 124
 401 test("@qr", "b\\b qq .\\. qq"); # 125
 402 test($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;
 413 oups
 414 EOF
 415   $b = <<'EOF';
 416 oups1
 417 EOF
 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
 425 test($out, '_<foo>_');          # 117
 426 test($out1, '_<f\'o\\o>_');             # 128
 427 test($out2, "_<a\a>_foo_<,\,>_");       # 129
 428 test("@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
 431 test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq");   # 131
 432 test($res, 1);                  # 132
 433 test($a, "_<oups
 434 >_");   # 133
 435 test($b, "_<oups1
 436 >_");   # 134
 437 test($c, "bareword");   # 135
 438
 439
 440 # Last test is:
 441 sub last {135}