home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / overload.t < prev    next >
Text File  |  1999-12-27  |  22KB  |  933 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6. }
  7.  
  8. package Oscalar;
  9. use overload ( 
  10.                 # Anonymous subroutines:
  11. '+'    =>    sub {new Oscalar $ {$_[0]}+$_[1]},
  12. '-'    =>    sub {new Oscalar
  13.                $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
  14. '<=>'    =>    sub {new Oscalar
  15.                $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
  16. 'cmp'    =>    sub {new Oscalar
  17.                $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
  18. '*'    =>    sub {new Oscalar ${$_[0]}*$_[1]},
  19. '/'    =>    sub {new Oscalar 
  20.                $_[2]? $_[1]/${$_[0]} :
  21.              ${$_[0]}/$_[1]},
  22. '%'    =>    sub {new Oscalar
  23.                $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
  24. '**'    =>    sub {new Oscalar
  25.                $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
  26.  
  27. qw(
  28. ""    stringify
  29. 0+    numify)            # Order of arguments unsignificant
  30. );
  31.  
  32. sub new {
  33.   my $foo = $_[1];
  34.   bless \$foo, $_[0];
  35. }
  36.  
  37. sub stringify { "${$_[0]}" }
  38. sub numify { 0 + "${$_[0]}" }    # Not needed, additional overhead
  39.                 # comparing to direct compilation based on
  40.                 # stringify
  41.  
  42. package main;
  43.  
  44. $test = 0;
  45. $| = 1;
  46. print "1..",&last,"\n";
  47.  
  48. sub test {
  49.   $test++; 
  50.   if (@_ > 1) {
  51.     if ($_[0] eq $_[1]) {
  52.       print "ok $test\n";
  53.     } else {
  54.       print "not ok $test: '$_[0]' ne '$_[1]'\n";
  55.     }
  56.   } else {
  57.     if (shift) {
  58.       print "ok $test\n";
  59.     } else {
  60.       print "not ok $test\n";
  61.     } 
  62.   }
  63. }
  64.  
  65. $a = new Oscalar "087";
  66. $b= "$a";
  67.  
  68. # All test numbers in comments are off by 1.
  69. # So much for hard-wiring them in :-) To fix this:
  70. test(1);            # 1
  71.  
  72. test ($b eq $a);        # 2
  73. test ($b eq "087");        # 3
  74. test (ref $a eq "Oscalar");    # 4
  75. test ($a eq $a);        # 5
  76. test ($a eq "087");        # 6
  77.  
  78. $c = $a + 7;
  79.  
  80. test (ref $c eq "Oscalar");    # 7
  81. test (!($c eq $a));        # 8
  82. test ($c eq "94");        # 9
  83.  
  84. $b=$a;
  85.  
  86. test (ref $a eq "Oscalar");    # 10
  87.  
  88. $b++;
  89.  
  90. test (ref $b eq "Oscalar");    # 11
  91. test ( $a eq "087");        # 12
  92. test ( $b eq "88");        # 13
  93. test (ref $a eq "Oscalar");    # 14
  94.  
  95. $c=$b;
  96. $c-=$a;
  97.  
  98. test (ref $c eq "Oscalar");    # 15
  99. test ( $a eq "087");        # 16
  100. test ( $c eq "1");        # 17
  101. test (ref $a eq "Oscalar");    # 18
  102.  
  103. $b=1;
  104. $b+=$a;
  105.  
  106. test (ref $b eq "Oscalar");    # 19
  107. test ( $a eq "087");        # 20
  108. test ( $b eq "88");        # 21
  109. test (ref $a eq "Oscalar");    # 22
  110.  
  111. eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
  112.  
  113. $b=$a;
  114.  
  115. test (ref $a eq "Oscalar");    # 23
  116.  
  117. $b++;
  118.  
  119. test (ref $b eq "Oscalar");    # 24
  120. test ( $a eq "087");        # 25
  121. test ( $b eq "88");        # 26
  122. test (ref $a eq "Oscalar");    # 27
  123.  
  124. package Oscalar;
  125. $dummy=bless \$dummy;        # Now cache of method should be reloaded
  126. package main;
  127.  
  128. $b=$a;
  129. $b++;                
  130.  
  131. test (ref $b eq "Oscalar");    # 28
  132. test ( $a eq "087");        # 29
  133. test ( $b eq "88");        # 30
  134. test (ref $a eq "Oscalar");    # 31
  135.  
  136.  
  137. eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
  138.  
  139. $b=$a;
  140.  
  141. test (ref $a eq "Oscalar");    # 32
  142.  
  143. $b++;
  144.  
  145. test (ref $b eq "Oscalar");    # 33
  146. test ( $a eq "087");        # 34
  147. test ( $b eq "88");        # 35
  148. test (ref $a eq "Oscalar");    # 36
  149.  
  150. package Oscalar;
  151. $dummy=bless \$dummy;        # Now cache of method should be reloaded
  152. package main;
  153.  
  154. $b++;                
  155.  
  156. test (ref $b eq "Oscalar");    # 37
  157. test ( $a eq "087");        # 38
  158. test ( $b eq "90");        # 39
  159. test (ref $a eq "Oscalar");    # 40
  160.  
  161. $b=$a;
  162. $b++;
  163.  
  164. test (ref $b eq "Oscalar");    # 41
  165. test ( $a eq "087");        # 42
  166. test ( $b eq "89");        # 43
  167. test (ref $a eq "Oscalar");    # 44
  168.  
  169.  
  170. test ($b? 1:0);            # 45
  171.  
  172. eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; 
  173.                            package Oscalar;
  174.                            local $new=$ {$_[0]};
  175.                            bless \$new } ) ];
  176.  
  177. $b=new Oscalar "$a";
  178.  
  179. test (ref $b eq "Oscalar");    # 46
  180. test ( $a eq "087");        # 47
  181. test ( $b eq "087");        # 48
  182. test (ref $a eq "Oscalar");    # 49
  183.  
  184. $b++;
  185.  
  186. test (ref $b eq "Oscalar");    # 50
  187. test ( $a eq "087");        # 51
  188. test ( $b eq "89");        # 52
  189. test (ref $a eq "Oscalar");    # 53
  190. test ($copies == 0);        # 54
  191.  
  192. $b+=1;
  193.  
  194. test (ref $b eq "Oscalar");    # 55
  195. test ( $a eq "087");        # 56
  196. test ( $b eq "90");        # 57
  197. test (ref $a eq "Oscalar");    # 58
  198. test ($copies == 0);        # 59
  199.  
  200. $b=$a;
  201. $b+=1;
  202.  
  203. test (ref $b eq "Oscalar");    # 60
  204. test ( $a eq "087");        # 61
  205. test ( $b eq "88");        # 62
  206. test (ref $a eq "Oscalar");    # 63
  207. test ($copies == 0);        # 64
  208.  
  209. $b=$a;
  210. $b++;
  211.  
  212. test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n";    # 65
  213. test ( $a eq "087");        # 66
  214. test ( $b eq "89");        # 67
  215. test (ref $a eq "Oscalar");    # 68
  216. test ($copies == 1);        # 69
  217.  
  218. eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
  219.                            $_[0] } ) ];
  220. $c=new Oscalar;            # Cause rehash
  221.  
  222. $b=$a;
  223. $b+=1;
  224.  
  225. test (ref $b eq "Oscalar");    # 70
  226. test ( $a eq "087");        # 71
  227. test ( $b eq "90");        # 72
  228. test (ref $a eq "Oscalar");    # 73
  229. test ($copies == 2);        # 74
  230.  
  231. $b+=$b;
  232.  
  233. test (ref $b eq "Oscalar");    # 75
  234. test ( $b eq "360");        # 76
  235. test ($copies == 2);        # 77
  236. $b=-$b;
  237.  
  238. test (ref $b eq "Oscalar");    # 78
  239. test ( $b eq "-360");        # 79
  240. test ($copies == 2);        # 80
  241.  
  242. $b=abs($b);
  243.  
  244. test (ref $b eq "Oscalar");    # 81
  245. test ( $b eq "360");        # 82
  246. test ($copies == 2);        # 83
  247.  
  248. $b=abs($b);
  249.  
  250. test (ref $b eq "Oscalar");    # 84
  251. test ( $b eq "360");        # 85
  252. test ($copies == 2);        # 86
  253.  
  254. eval q[package Oscalar; 
  255.        use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
  256.                           : "_.${$_[0]}._" x $_[1])}) ];
  257.  
  258. $a=new Oscalar "yy";
  259. $a x= 3;
  260. test ($a eq "_.yy.__.yy.__.yy._"); # 87
  261.  
  262. eval q[package Oscalar; 
  263.        use overload ('.' => sub {new Oscalar ( $_[2] ? 
  264.                           "_.$_[1].__.$ {$_[0]}._"
  265.                           : "_.$ {$_[0]}.__.$_[1]._")}) ];
  266.  
  267. $a=new Oscalar "xx";
  268.  
  269. test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
  270.  
  271. # Check inheritance of overloading;
  272. {
  273.   package OscalarI;
  274.   @ISA = 'Oscalar';
  275. }
  276.  
  277. $aI = new OscalarI "$a";
  278. test (ref $aI eq "OscalarI");    # 89
  279. test ("$aI" eq "xx");        # 90
  280. test ($aI eq "xx");        # 91
  281. test ("b${aI}c" eq "_._.b.__.xx._.__.c._");        # 92
  282.  
  283. # Here we test blessing to a package updates hash
  284.  
  285. eval "package Oscalar; no overload '.'";
  286.  
  287. test ("b${a}" eq "_.b.__.xx._"); # 93
  288. $x="1";
  289. bless \$x, Oscalar;
  290. test ("b${a}c" eq "bxxc");    # 94
  291. new Oscalar 1;
  292. test ("b${a}c" eq "bxxc");    # 95
  293.  
  294. # Negative overloading:
  295.  
  296. $na = eval { ~$a };
  297. test($@ =~ /no method found/);    # 96
  298.  
  299. # Check AUTOLOADING:
  300.  
  301. *Oscalar::AUTOLOAD = 
  302.   sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
  303.     goto &{"Oscalar::$AUTOLOAD"}};
  304.  
  305. eval "package Oscalar; sub comple; use overload '~' => 'comple'";
  306.  
  307. $na = eval { ~$a };        # Hash was not updated
  308. test($@ =~ /no method found/);    # 97
  309.  
  310. bless \$x, Oscalar;
  311.  
  312. $na = eval { ~$a };        # Hash updated
  313. warn "`$na', $@" if $@;
  314. test !$@;            # 98
  315. test($na eq '_!_xx_!_');    # 99
  316.  
  317. $na = 0;
  318.  
  319. $na = eval { ~$aI };        # Hash was not updated
  320. test($@ =~ /no method found/);    # 100
  321.  
  322. bless \$x, OscalarI;
  323.  
  324. $na = eval { ~$aI };
  325. print $@;
  326.  
  327. test !$@;            # 101
  328. test($na eq '_!_xx_!_');    # 102
  329.  
  330. eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
  331.  
  332. $na = eval { $aI >> 1 };    # Hash was not updated
  333. test($@ =~ /no method found/);    # 103
  334.  
  335. bless \$x, OscalarI;
  336.  
  337. $na = 0;
  338.  
  339. $na = eval { $aI >> 1 };
  340. print $@;
  341.  
  342. test !$@;            # 104
  343. test($na eq '_!_xx_!_');    # 105
  344.  
  345. # warn overload::Method($a, '0+'), "\n";
  346. test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
  347. test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
  348. test (overload::Overloaded($aI)); # 108
  349. test (!overload::Overloaded('overload')); # 109
  350.  
  351. test (! defined overload::Method($aI, '<<')); # 110
  352. test (! defined overload::Method($a, '<')); # 111
  353.  
  354. test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
  355. test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
  356.  
  357. # Check overloading by methods (specified deep in the ISA tree).
  358. {
  359.   package OscalarII;
  360.   @ISA = 'OscalarI';
  361.   sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
  362.   eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
  363. }
  364.  
  365. $aaII = "087";
  366. $aII = \$aaII;
  367. bless $aII, 'OscalarII';
  368. bless \$fake, 'OscalarI';        # update the hash
  369. test(($aI | 3) eq '_<<_xx_<<_');    # 114
  370. # warn $aII << 3;
  371. test(($aII << 3) eq '_<<_087_<<_');    # 115
  372.  
  373. {
  374.   BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
  375.   $out = 2**10;
  376. }
  377. test($int, 9);        # 116
  378. test($out, 1024);        # 117
  379.  
  380. $foo = 'foo';
  381. $foo1 = 'f\'o\\o';
  382. {
  383.   BEGIN { $q = $qr = 7; 
  384.       overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift},
  385.                  'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; }
  386.   $out = 'foo';
  387.   $out1 = 'f\'o\\o';
  388.   $out2 = "a\a$foo,\,";
  389.   /b\b$foo.\./;
  390. }
  391.  
  392. test($out, 'foo');        # 118
  393. test($out, $foo);        # 119
  394. test($out1, 'f\'o\\o');        # 120
  395. test($out1, $foo1);        # 121
  396. test($out2, "a\afoo,\,");    # 122
  397. test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq");    # 123
  398. test($q, 11);            # 124
  399. test("@qr", "b\\b qq .\\. qq");    # 125
  400. test($qr, 9);            # 126
  401.  
  402. {
  403.   $_ = '!<b>!foo!<-.>!';
  404.   BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
  405.                  'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
  406.   $out = 'foo';
  407.   $out1 = 'f\'o\\o';
  408.   $out2 = "a\a$foo,\,";
  409.   $res = /b\b$foo.\./;
  410.   $a = <<EOF;
  411. oups
  412. EOF
  413.   $b = <<'EOF';
  414. oups1
  415. EOF
  416.   $c = bareword;
  417.   m'try it';
  418.   s'first part'second part';
  419.   s/yet another/tail here/;
  420.   tr/z-Z/z-Z/;
  421. }
  422.  
  423. test($out, '_<foo>_');        # 117
  424. test($out1, '_<f\'o\\o>_');        # 128
  425. test($out2, "_<a\a>_foo_<,\,>_");    # 129
  426. test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
  427.  qq oups1
  428.  q second part q tail here s z-Z tr z-Z tr");    # 130
  429. test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq");    # 131
  430. test($res, 1);            # 132
  431. test($a, "_<oups
  432. >_");    # 133
  433. test($b, "_<oups1
  434. >_");    # 134
  435. test($c, "bareword");    # 135
  436.  
  437. {
  438.   package symbolic;        # Primitive symbolic calculator
  439.   use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
  440.       '=' => \&cpy, '++' => \&inc, '--' => \&dec;
  441.  
  442.   sub new { shift; bless ['n', @_] }
  443.   sub cpy {
  444.     my $self = shift;
  445.     bless [@$self], ref $self;
  446.   }
  447.   sub inc { $_[0] = bless ['++', $_[0], 1]; }
  448.   sub dec { $_[0] = bless ['--', $_[0], 1]; }
  449.   sub wrap {
  450.     my ($obj, $other, $inv, $meth) = @_;
  451.     if ($meth eq '++' or $meth eq '--') {
  452.       @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
  453.       return $obj;
  454.     }
  455.     ($obj, $other) = ($other, $obj) if $inv;
  456.     bless [$meth, $obj, $other];
  457.   }
  458.   sub str {
  459.     my ($meth, $a, $b) = @{+shift};
  460.     $a = 'u' unless defined $a;
  461.     if (defined $b) {
  462.       "[$meth $a $b]";
  463.     } else {
  464.       "[$meth $a]";
  465.     }
  466.   } 
  467.   my %subr = ( 'n' => sub {$_[0]} );
  468.   foreach my $op (split " ", $overload::ops{with_assign}) {
  469.     $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
  470.   }
  471.   my @bins = qw(binary 3way_comparison num_comparison str_comparison);
  472.   foreach my $op (split " ", "@overload::ops{ @bins }") {
  473.     $subr{$op} = eval "sub {shift() $op shift()}";
  474.   }
  475.   foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
  476.     $subr{$op} = eval "sub {$op shift()}";
  477.   }
  478.   $subr{'++'} = $subr{'+'};
  479.   $subr{'--'} = $subr{'-'};
  480.   
  481.   sub num {
  482.     my ($meth, $a, $b) = @{+shift};
  483.     my $subr = $subr{$meth} 
  484.       or die "Do not know how to ($meth) in symbolic";
  485.     $a = $a->num if ref $a eq __PACKAGE__;
  486.     $b = $b->num if ref $b eq __PACKAGE__;
  487.     $subr->($a,$b);
  488.   }
  489.   sub TIESCALAR { my $pack = shift; $pack->new(@_) }
  490.   sub FETCH { shift }
  491.   sub nop {  }        # Around a bug
  492.   sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
  493.   sub STORE { 
  494.     my $obj = shift; 
  495.     $#$obj = 1; 
  496.     @$obj->[0,1] = ('=', shift);
  497.   }
  498. }
  499.  
  500. {
  501.   my $foo = new symbolic 11;
  502.   my $baz = $foo++;
  503.   test( (sprintf "%d", $foo), '12');
  504.   test( (sprintf "%d", $baz), '11');
  505.   my $bar = $foo;
  506.   $baz = ++$foo;
  507.   test( (sprintf "%d", $foo), '13');
  508.   test( (sprintf "%d", $bar), '12');
  509.   test( (sprintf "%d", $baz), '13');
  510.   my $ban = $foo;
  511.   $baz = ($foo += 1);
  512.   test( (sprintf "%d", $foo), '14');
  513.   test( (sprintf "%d", $bar), '12');
  514.   test( (sprintf "%d", $baz), '14');
  515.   test( (sprintf "%d", $ban), '13');
  516.   $baz = 0;
  517.   $baz = $foo++;
  518.   test( (sprintf "%d", $foo), '15');
  519.   test( (sprintf "%d", $baz), '14');
  520.   test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
  521. }
  522.  
  523. {
  524.   my $iter = new symbolic 2;
  525.   my $side = new symbolic 1;
  526.   my $cnt = $iter;
  527.   
  528.   while ($cnt) {
  529.     $cnt = $cnt - 1;        # The "simple" way
  530.     $side = (sqrt(1 + $side**2) - 1)/$side;
  531.   }
  532.   my $pi = $side*(2**($iter+2));
  533.   test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
  534.   test( (sprintf "%f", $pi), '3.182598');
  535. }
  536.  
  537. {
  538.   my $iter = new symbolic 2;
  539.   my $side = new symbolic 1;
  540.   my $cnt = $iter;
  541.   
  542.   while ($cnt--) {
  543.     $side = (sqrt(1 + $side**2) - 1)/$side;
  544.   }
  545.   my $pi = $side*(2**($iter+2));
  546.   test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
  547.   test( (sprintf "%f", $pi), '3.182598');
  548. }
  549.  
  550. {
  551.   my ($a, $b);
  552.   symbolic->vars($a, $b);
  553.   my $c = sqrt($a**2 + $b**2);
  554.   $a = 3; $b = 4;
  555.   test( (sprintf "%d", $c), '5');
  556.   $a = 12; $b = 5;
  557.   test( (sprintf "%d", $c), '13');
  558. }
  559.  
  560. {
  561.   package symbolic1;        # Primitive symbolic calculator
  562.   # Mutator inc/dec
  563.   use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
  564.  
  565.   sub new { shift; bless ['n', @_] }
  566.   sub cpy {
  567.     my $self = shift;
  568.     bless [@$self], ref $self;
  569.   }
  570.   sub wrap {
  571.     my ($obj, $other, $inv, $meth) = @_;
  572.     if ($meth eq '++' or $meth eq '--') {
  573.       @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
  574.       return $obj;
  575.     }
  576.     ($obj, $other) = ($other, $obj) if $inv;
  577.     bless [$meth, $obj, $other];
  578.   }
  579.   sub str {
  580.     my ($meth, $a, $b) = @{+shift};
  581.     $a = 'u' unless defined $a;
  582.     if (defined $b) {
  583.       "[$meth $a $b]";
  584.     } else {
  585.       "[$meth $a]";
  586.     }
  587.   } 
  588.   my %subr = ( 'n' => sub {$_[0]} );
  589.   foreach my $op (split " ", $overload::ops{with_assign}) {
  590.     $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
  591.   }
  592.   my @bins = qw(binary 3way_comparison num_comparison str_comparison);
  593.   foreach my $op (split " ", "@overload::ops{ @bins }") {
  594.     $subr{$op} = eval "sub {shift() $op shift()}";
  595.   }
  596.   foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
  597.     $subr{$op} = eval "sub {$op shift()}";
  598.   }
  599.   $subr{'++'} = $subr{'+'};
  600.   $subr{'--'} = $subr{'-'};
  601.   
  602.   sub num {
  603.     my ($meth, $a, $b) = @{+shift};
  604.     my $subr = $subr{$meth} 
  605.       or die "Do not know how to ($meth) in symbolic";
  606.     $a = $a->num if ref $a eq __PACKAGE__;
  607.     $b = $b->num if ref $b eq __PACKAGE__;
  608.     $subr->($a,$b);
  609.   }
  610.   sub TIESCALAR { my $pack = shift; $pack->new(@_) }
  611.   sub FETCH { shift }
  612.   sub nop {  }        # Around a bug
  613.   sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
  614.   sub STORE { 
  615.     my $obj = shift; 
  616.     $#$obj = 1; 
  617.     @$obj->[0,1] = ('=', shift);
  618.   }
  619. }
  620.  
  621. {
  622.   my $foo = new symbolic1 11;
  623.   my $baz = $foo++;
  624.   test( (sprintf "%d", $foo), '12');
  625.   test( (sprintf "%d", $baz), '11');
  626.   my $bar = $foo;
  627.   $baz = ++$foo;
  628.   test( (sprintf "%d", $foo), '13');
  629.   test( (sprintf "%d", $bar), '12');
  630.   test( (sprintf "%d", $baz), '13');
  631.   my $ban = $foo;
  632.   $baz = ($foo += 1);
  633.   test( (sprintf "%d", $foo), '14');
  634.   test( (sprintf "%d", $bar), '12');
  635.   test( (sprintf "%d", $baz), '14');
  636.   test( (sprintf "%d", $ban), '13');
  637.   $baz = 0;
  638.   $baz = $foo++;
  639.   test( (sprintf "%d", $foo), '15');
  640.   test( (sprintf "%d", $baz), '14');
  641.   test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
  642. }
  643.  
  644. {
  645.   my $iter = new symbolic1 2;
  646.   my $side = new symbolic1 1;
  647.   my $cnt = $iter;
  648.   
  649.   while ($cnt) {
  650.     $cnt = $cnt - 1;        # The "simple" way
  651.     $side = (sqrt(1 + $side**2) - 1)/$side;
  652.   }
  653.   my $pi = $side*(2**($iter+2));
  654.   test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
  655.   test( (sprintf "%f", $pi), '3.182598');
  656. }
  657.  
  658. {
  659.   my $iter = new symbolic1 2;
  660.   my $side = new symbolic1 1;
  661.   my $cnt = $iter;
  662.   
  663.   while ($cnt--) {
  664.     $side = (sqrt(1 + $side**2) - 1)/$side;
  665.   }
  666.   my $pi = $side*(2**($iter+2));
  667.   test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
  668.   test( (sprintf "%f", $pi), '3.182598');
  669. }
  670.  
  671. {
  672.   my ($a, $b);
  673.   symbolic1->vars($a, $b);
  674.   my $c = sqrt($a**2 + $b**2);
  675.   $a = 3; $b = 4;
  676.   test( (sprintf "%d", $c), '5');
  677.   $a = 12; $b = 5;
  678.   test( (sprintf "%d", $c), '13');
  679. }
  680.  
  681. {
  682.   package two_face;        # Scalars with separate string and
  683.                                 # numeric values.
  684.   sub new { my $p = shift; bless [@_], $p }
  685.   use overload '""' => \&str, '0+' => \&num, fallback => 1;
  686.   sub num {shift->[1]}
  687.   sub str {shift->[0]}
  688. }
  689.  
  690. {
  691.   my $seven = new two_face ("vii", 7);
  692.   test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1),
  693.     'seven=vii, seven=7, eight=8');
  694.   test( scalar ($seven =~ /i/), '1')
  695. }
  696.  
  697. {
  698.   package sorting;
  699.   use overload 'cmp' => \∁
  700.   sub new { my ($p, $v) = @_; bless \$v, $p }
  701.   sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
  702. }
  703. {
  704.   my @arr = map sorting->new($_), 0..12;
  705.   my @sorted1 = sort @arr;
  706.   my @sorted2 = map $$_, @sorted1;
  707.   test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3';
  708. }
  709. {
  710.   package iterator;
  711.   use overload '<>' => \&iter;
  712.   sub new { my ($p, $v) = @_; bless \$v, $p }
  713.   sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
  714. }
  715.  
  716. # XXX iterator overload not intended to work with CORE::GLOBAL?
  717. if (defined &CORE::GLOBAL::glob) {
  718.   test '1', '1';    # 175
  719.   test '1', '1';    # 176
  720.   test '1', '1';    # 177
  721. }
  722. else {
  723.   my $iter = iterator->new(5);
  724.   my $acc = '';
  725.   my $out;
  726.   $acc .= " $out" while $out = <${iter}>;
  727.   test $acc, ' 5 4 3 2 1 0';    # 175
  728.   $iter = iterator->new(5);
  729.   test scalar <${iter}>, '5';    # 176
  730.   $acc = '';
  731.   $acc .= " $out" while $out = <$iter>;
  732.   test $acc, ' 4 3 2 1 0';    # 177
  733. }
  734. {
  735.   package deref;
  736.   use overload '%{}' => \&hderef, '&{}' => \&cderef, 
  737.     '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
  738.   sub new { my ($p, $v) = @_; bless \$v, $p }
  739.   sub deref {
  740.     my ($self, $key) = (shift, shift);
  741.     my $class = ref $self;
  742.     bless $self, 'deref::dummy'; # Disable overloading of %{} 
  743.     my $out = $self->{$key};
  744.     bless $self, $class;    # Restore overloading
  745.     $out;
  746.   }
  747.   sub hderef {shift->deref('h')}
  748.   sub aderef {shift->deref('a')}
  749.   sub cderef {shift->deref('c')}
  750.   sub gderef {shift->deref('g')}
  751.   sub sderef {shift->deref('s')}
  752. }
  753. {
  754.   my $deref = bless { h => { foo => 5 , fake => 23 },
  755.               c => sub {return shift() + 34},
  756.               's' => \123,
  757.               a => [11..13],
  758.               g => \*srt,
  759.             }, 'deref';
  760.   # Hash:
  761.   my @cont = sort %$deref;
  762.   if ("\t" eq "\011") { # ascii
  763.       test "@cont", '23 5 fake foo';    # 178
  764.   } 
  765.   else {                # ebcdic alpha-numeric sort order
  766.       test "@cont", 'fake foo 23 5';    # 178
  767.   }
  768.   my @keys = sort keys %$deref;
  769.   test "@keys", 'fake foo';    # 179
  770.   my @val = sort values %$deref;
  771.   test "@val", '23 5';        # 180
  772.   test $deref->{foo}, 5;    # 181
  773.   test defined $deref->{bar}, ''; # 182
  774.   my $key;
  775.   @keys = ();
  776.   push @keys, $key while $key = each %$deref;
  777.   @keys = sort @keys;
  778.   test "@keys", 'fake foo';    # 183  
  779.   test exists $deref->{bar}, ''; # 184
  780.   test exists $deref->{foo}, 1; # 185
  781.   # Code:
  782.   test $deref->(5), 39;        # 186
  783.   test &$deref(6), 40;        # 187
  784.   sub xxx_goto { goto &$deref }
  785.   test xxx_goto(7), 41;        # 188
  786.   my $srt = bless { c => sub {$b <=> $a}
  787.           }, 'deref';
  788.   *srt = \&$srt;
  789.   my @sorted = sort srt 11, 2, 5, 1, 22;
  790.   test "@sorted", '22 11 5 2 1'; # 189
  791.   # Scalar
  792.   test $$deref, 123;        # 190
  793.   # Code
  794.   @sorted = sort $srt 11, 2, 5, 1, 22;
  795.   test "@sorted", '22 11 5 2 1'; # 191
  796.   # Array
  797.   test "@$deref", '11 12 13';    # 192
  798.   test $#$deref, '2';        # 193
  799.   my $l = @$deref;
  800.   test $l, 3;            # 194
  801.   test $deref->[2], '13';        # 195
  802.   $l = pop @$deref;
  803.   test $l, 13;            # 196
  804.   $l = 1;
  805.   test $deref->[$l], '12';    # 197
  806.   # Repeated dereference
  807.   my $double = bless { h => $deref,
  808.              }, 'deref';
  809.   test $double->{foo}, 5;    # 198
  810. }
  811.  
  812. {
  813.   package two_refs;
  814.   use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
  815.   sub new { 
  816.     my $p = shift; 
  817.     bless \ [@_], $p;
  818.   }
  819.   sub gethash {
  820.     my %h;
  821.     my $self = shift;
  822.     tie %h, ref $self, $self;
  823.     \%h;
  824.   }
  825.  
  826.   sub TIEHASH { my $p = shift; bless \ shift, $p }
  827.   my %fields;
  828.   my $i = 0;
  829.   $fields{$_} = $i++ foreach qw{zero one two three};
  830.   sub STORE { 
  831.     my $self = ${shift()};
  832.     my $key = $fields{shift()};
  833.     defined $key or die "Out of band access";
  834.     $$self->[$key] = shift;
  835.   }
  836.   sub FETCH { 
  837.     my $self = ${shift()};
  838.     my $key = $fields{shift()};
  839.     defined $key or die "Out of band access";
  840.     $$self->[$key];
  841.   }
  842. }
  843.  
  844. my $bar = new two_refs 3,4,5,6;
  845. $bar->[2] = 11;
  846. test $bar->{two}, 11;        # 199
  847. $bar->{three} = 13;
  848. test $bar->[3], 13;        # 200
  849.  
  850. {
  851.   package two_refs_o;
  852.   @ISA = ('two_refs');
  853. }
  854.  
  855. $bar = new two_refs_o 3,4,5,6;
  856. $bar->[2] = 11;
  857. test $bar->{two}, 11;        # 201
  858. $bar->{three} = 13;
  859. test $bar->[3], 13;        # 202
  860.  
  861. {
  862.   package two_refs1;
  863.   use overload '%{}' => sub { ${shift()}->[1] },
  864.                '@{}' => sub { ${shift()}->[0] };
  865.   sub new { 
  866.     my $p = shift; 
  867.     my $a = [@_];
  868.     my %h;
  869.     tie %h, $p, $a;
  870.     bless \ [$a, \%h], $p;
  871.   }
  872.   sub gethash {
  873.     my %h;
  874.     my $self = shift;
  875.     tie %h, ref $self, $self;
  876.     \%h;
  877.   }
  878.  
  879.   sub TIEHASH { my $p = shift; bless \ shift, $p }
  880.   my %fields;
  881.   my $i = 0;
  882.   $fields{$_} = $i++ foreach qw{zero one two three};
  883.   sub STORE { 
  884.     my $a = ${shift()};
  885.     my $key = $fields{shift()};
  886.     defined $key or die "Out of band access";
  887.     $a->[$key] = shift;
  888.   }
  889.   sub FETCH { 
  890.     my $a = ${shift()};
  891.     my $key = $fields{shift()};
  892.     defined $key or die "Out of band access";
  893.     $a->[$key];
  894.   }
  895. }
  896.  
  897. $bar = new two_refs_o 3,4,5,6;
  898. $bar->[2] = 11;
  899. test $bar->{two}, 11;        # 203
  900. $bar->{three} = 13;
  901. test $bar->[3], 13;        # 204
  902.  
  903. {
  904.   package two_refs1_o;
  905.   @ISA = ('two_refs1');
  906. }
  907.  
  908. $bar = new two_refs1_o 3,4,5,6;
  909. $bar->[2] = 11;
  910. test $bar->{two}, 11;        # 205
  911. $bar->{three} = 13;
  912. test $bar->[3], 13;        # 206
  913.  
  914. {
  915.   package B;
  916.   use overload bool => sub { ${+shift} };
  917. }
  918.  
  919. my $aaa;
  920. { my $bbbb = 0; $aaa = bless \$bbbb, B }
  921.  
  922. test !$aaa, 1;
  923.  
  924. unless ($aaa) {
  925.   test 'ok', 'ok';
  926. } else {
  927.   test 'is not', 'ok';
  928. }
  929.  
  930.  
  931. # Last test is:
  932. sub last {208}
  933.