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++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0}
  52 }
  53
  54 $a = new Oscalar "087";
  55 $b= "$a";
  56
  57 # All test numbers in comments are off by 1.
  58 # So much for hard-wiring them in :-) To fix this:
  59 test(1);                        # 1
  60
  61 test ($b eq $a);                # 2
  62 test ($b eq "087");             # 3
  63 test (ref $a eq "Oscalar");     # 4
  64 test ($a eq $a);                # 5
  65 test ($a eq "087");             # 6
  66
  67 $c = $a + 7;
  68
  69 test (ref $c eq "Oscalar");     # 7
  70 test (!($c eq $a));             # 8
  71 test ($c eq "94");              # 9
  72
  73 $b=$a;
  74
  75 test (ref $a eq "Oscalar");     # 10
  76
  77 $b++;
  78
  79 test (ref $b eq "Oscalar");     # 11
  80 test ( $a eq "087");            # 12
  81 test ( $b eq "88");             # 13
  82 test (ref $a eq "Oscalar");     # 14
  83
  84 $c=$b;
  85 $c-=$a;
  86
  87 test (ref $c eq "Oscalar");     # 15
  88 test ( $a eq "087");            # 16
  89 test ( $c eq "1");              # 17
  90 test (ref $a eq "Oscalar");     # 18
  91
  92 $b=1;
  93 $b+=$a;
  94
  95 test (ref $b eq "Oscalar");     # 19
  96 test ( $a eq "087");            # 20
  97 test ( $b eq "88");             # 21
  98 test (ref $a eq "Oscalar");     # 22
  99
 100 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
 101
 102 $b=$a;
 103
 104 test (ref $a eq "Oscalar");     # 23
 105
 106 $b++;
 107
 108 test (ref $b eq "Oscalar");     # 24
 109 test ( $a eq "087");            # 25
 110 test ( $b eq "88");             # 26
 111 test (ref $a eq "Oscalar");     # 27
 112
 113 package Oscalar;
 114 $dummy=bless \$dummy;           # Now cache of method should be reloaded
 115 package main;
 116
 117 $b=$a;
 118 $b++;
 119
 120 test (ref $b eq "Oscalar");     # 28
 121 test ( $a eq "087");            # 29
 122 test ( $b eq "88");             # 30
 123 test (ref $a eq "Oscalar");     # 31
 124
 125
 126 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
 127
 128 $b=$a;
 129
 130 test (ref $a eq "Oscalar");     # 32
 131
 132 $b++;
 133
 134 test (ref $b eq "Oscalar");     # 33
 135 test ( $a eq "087");            # 34
 136 test ( $b eq "88");             # 35
 137 test (ref $a eq "Oscalar");     # 36
 138
 139 package Oscalar;
 140 $dummy=bless \$dummy;           # Now cache of method should be reloaded
 141 package main;
 142
 143 $b++;
 144
 145 test (ref $b eq "Oscalar");     # 37
 146 test ( $a eq "087");            # 38
 147 test ( $b eq "90");             # 39
 148 test (ref $a eq "Oscalar");     # 40
 149
 150 $b=$a;
 151 $b++;
 152
 153 test (ref $b eq "Oscalar");     # 41
 154 test ( $a eq "087");            # 42
 155 test ( $b eq "89");             # 43
 156 test (ref $a eq "Oscalar");     # 44
 157
 158
 159 test ($b? 1:0);                 # 45
 160
 161 eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
 162                                                    package Oscalar;
 163                                                    local $new=$ {$_[0]};
 164                                                    bless \$new } ) ];
 165
 166 $b=new Oscalar "$a";
 167
 168 test (ref $b eq "Oscalar");     # 46
 169 test ( $a eq "087");            # 47
 170 test ( $b eq "087");            # 48
 171 test (ref $a eq "Oscalar");     # 49
 172
 173 $b++;
 174
 175 test (ref $b eq "Oscalar");     # 50
 176 test ( $a eq "087");            # 51
 177 test ( $b eq "89");             # 52
 178 test (ref $a eq "Oscalar");     # 53
 179 test ($copies == 0);            # 54
 180
 181 $b+=1;
 182
 183 test (ref $b eq "Oscalar");     # 55
 184 test ( $a eq "087");            # 56
 185 test ( $b eq "90");             # 57
 186 test (ref $a eq "Oscalar");     # 58
 187 test ($copies == 0);            # 59
 188
 189 $b=$a;
 190 $b+=1;
 191
 192 test (ref $b eq "Oscalar");     # 60
 193 test ( $a eq "087");            # 61
 194 test ( $b eq "88");             # 62
 195 test (ref $a eq "Oscalar");     # 63
 196 test ($copies == 0);            # 64
 197
 198 $b=$a;
 199 $b++;
 200
 201 test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
 202 test ( $a eq "087");            # 66
 203 test ( $b eq "89");             # 67
 204 test (ref $a eq "Oscalar");     # 68
 205 test ($copies == 1);            # 69
 206
 207 eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
 208                                                    $_[0] } ) ];
 209 $c=new Oscalar;                 # Cause rehash
 210
 211 $b=$a;
 212 $b+=1;
 213
 214 test (ref $b eq "Oscalar");     # 70
 215 test ( $a eq "087");            # 71
 216 test ( $b eq "90");             # 72
 217 test (ref $a eq "Oscalar");     # 73
 218 test ($copies == 2);            # 74
 219
 220 $b+=$b;
 221
 222 test (ref $b eq "Oscalar");     # 75
 223 test ( $b eq "360");            # 76
 224 test ($copies == 2);            # 77
 225 $b=-$b;
 226
 227 test (ref $b eq "Oscalar");     # 78
 228 test ( $b eq "-360");           # 79
 229 test ($copies == 2);            # 80
 230
 231 $b=abs($b);
 232
 233 test (ref $b eq "Oscalar");     # 81
 234 test ( $b eq "360");            # 82
 235 test ($copies == 2);            # 83
 236
 237 $b=abs($b);
 238
 239 test (ref $b eq "Oscalar");     # 84
 240 test ( $b eq "360");            # 85
 241 test ($copies == 2);            # 86
 242
 243 eval q[package Oscalar;
 244        use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
 245                                               : "_.${$_[0]}._" x $_[1])}) ];
 246
 247 $a=new Oscalar "yy";
 248 $a x= 3;
 249 test ($a eq "_.yy.__.yy.__.yy._"); # 87
 250
 251 eval q[package Oscalar;
 252        use overload ('.' => sub {new Oscalar ( $_[2] ?
 253                                               "_.$_[1].__.$ {$_[0]}._"
 254                                               : "_.$ {$_[0]}.__.$_[1]._")}) ];
 255
 256 $a=new Oscalar "xx";
 257
 258 test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
 259
 260 # Check inheritance of overloading;
 261 {
 262   package OscalarI;
 263   @ISA = 'Oscalar';
 264 }
 265
 266 $aI = new OscalarI "$a";
 267 test (ref $aI eq "OscalarI");   # 89
 268 test ("$aI" eq "xx");           # 90
 269 test ($aI eq "xx");             # 91
 270 test ("b${aI}c" eq "_._.b.__.xx._.__.c._");             # 92
 271
 272 # Here we test blessing to a package updates hash
 273
 274 eval "package Oscalar; no overload '.'";
 275
 276 test ("b${a}" eq "_.b.__.xx._"); # 93
 277 $x="1";
 278 bless \$x, Oscalar;
 279 test ("b${a}c" eq "bxxc");      # 94
 280 new Oscalar 1;
 281 test ("b${a}c" eq "bxxc");      # 95
 282
 283 # Negative overloading:
 284
 285 $na = eval { ~$a };
 286 test($@ =~ /no method found/);  # 96
 287
 288 # Check AUTOLOADING:
 289
 290 *Oscalar::AUTOLOAD =
 291   sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
 292         goto &{"Oscalar::$AUTOLOAD"}};
 293
 294 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
 295
 296 $na = eval { ~$a };             # Hash was not updated
 297 test($@ =~ /no method found/);  # 97
 298
 299 bless \$x, Oscalar;
 300
 301 $na = eval { ~$a };             # Hash updated
 302 warn "`$na', $@" if $@;
 303 test !$@;                       # 98
 304 test($na eq '_!_xx_!_');        # 99
 305
 306 $na = 0;
 307
 308 $na = eval { ~$aI };            # Hash was not updated
 309 test($@ =~ /no method found/);  # 100
 310
 311 bless \$x, OscalarI;
 312
 313 $na = eval { ~$aI };
 314 print $@;
 315
 316 test !$@;                       # 101
 317 test($na eq '_!_xx_!_');        # 102
 318
 319 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
 320
 321 $na = eval { $aI >> 1 };        # Hash was not updated
 322 test($@ =~ /no method found/);  # 103
 323
 324 bless \$x, OscalarI;
 325
 326 $na = 0;
 327
 328 $na = eval { $aI >> 1 };
 329 print $@;
 330
 331 test !$@;                       # 104
 332 test($na eq '_!_xx_!_');        # 105
 333
 334 # warn overload::Method($a, '0+'), "\n";
 335 test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
 336 test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
 337 test (overload::Overloaded($aI)); # 108
 338 test (!overload::Overloaded('overload')); # 109
 339
 340 test (! defined overload::Method($aI, '<<')); # 110
 341 test (! defined overload::Method($a, '<')); # 111
 342
 343 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
 344 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
 345
 346 # Check overloading by methods (specified deep in the ISA tree).
 347 {
 348   package OscalarII;
 349   @ISA = 'OscalarI';
 350   sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
 351   eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
 352 }
 353
 354 $aaII = "087";
 355 $aII = \$aaII;
 356 bless $aII, 'OscalarII';
 357 bless \$fake, 'OscalarI';               # update the hash
 358 test(($aI | 3) eq '_<<_xx_<<_');        # 114
 359 # warn $aII << 3;
 360 test(($aII << 3) eq '_<<_087_<<_');     # 115
 361
 362 # Last test is:
 363 sub last {115}