This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixes for overloading bugs and docs, tweaked some
authorIlya Zakharevich <ilya@math.berkeley.edu>
Sat, 25 Jul 1998 21:28:16 +0000 (17:28 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Sat, 1 Aug 1998 19:52:19 +0000 (19:52 +0000)
Message-Id: <199807260128.VAA10543@monk.mps.ohio-state.edu>
Subject: [PATCH 5.004_76] better overloading

p4raw-id: //depot/maint-5.005/perl@1677

Changes
gv.c
lib/dumpvar.pl
lib/overload.pm
lib/perl5db.pl
t/pragma/overload.t

diff --git a/Changes b/Changes
index 9361b8a..5bca36a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -78,6 +78,11 @@ Version 5.005_01        First maintenance release of 5.005
 ----------------
 
 ____________________________________________________________________________
+[  1669] By: gsar                                  on 1998/07/26  23:19:02
+        Log: update Changes; add sv_*_mg() entries in win32/GenCAPI.pl
+     Branch: maint-5.005/perl
+           ! Changes proto.h win32/GenCAPI.pl
+____________________________________________________________________________
 [  1668] By: gsar                                  on 1998/07/26  21:12:11
         Log: s/TMP_CRLF_PATCH/PERL_STRICT_CR/ with sense reversed, so they
              can disable it from config.sh if they want; up patchlevel to 5_01;
diff --git a/gv.c b/gv.c
index e8a2f9d..a01956f 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1154,7 +1154,7 @@ amagic_call(SV *left, SV *right, int method, int flags)
   CV **cvp=NULL, **ocvp=NULL;
   AMT *amtp, *oamtp;
   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
-  int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
+  int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
   HV* stash;
   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
@@ -1171,16 +1171,19 @@ amagic_call(SV *left, SV *right, int method, int flags)
       int logic;
 
       /* look for substituted methods */
+      /* In all the covered cases we should be called with assign==0. */
         switch (method) {
         case inc_amg:
-          if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
-              || ((cv = cvp[off=add_amg]) && (postpr=1))) {
+          force_cpy = 1;
+          if ((cv = cvp[off=add_ass_amg])
+              || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
             right = &PL_sv_yes; lr = -1; assign = 1;
           }
           break;
         case dec_amg:
-          if (((cv = cvp[off=subtr_ass_amg])  && (inc_dec_ass=1))
-              || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
+          force_cpy = 1;
+          if ((cv = cvp[off = subtr_ass_amg])
+              || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
             right = &PL_sv_yes; lr = -1; assign = 1;
           }
           break;
@@ -1327,6 +1330,7 @@ amagic_call(SV *left, SV *right, int method, int flags)
        }
        return NULL;
       }
+      force_cpy = force_cpy || assign;
     }
   }
   if (!notfound) {
@@ -1343,14 +1347,33 @@ amagic_call(SV *left, SV *right, int method, int flags)
                 flags & AMGf_unary? " for argument" : "",
                 HvNAME(stash), 
                 fl? ",\n\tassignment variant used": "") );
+  }
     /* Since we use shallow copy during assignment, we need
      * to dublicate the contents, probably calling user-supplied
      * version of copy operator
      */
-    if ((method + assignshift==off 
-        && (assign || method==inc_amg || method==dec_amg))
-       || inc_dec_ass) RvDEEPCP(left);
-  }
+    /* We need to copy in following cases:
+     * a) Assignment form was called.
+     *                 assignshift==1,  assign==T, method + 1 == off
+     * b) Increment or decrement, called directly.
+     *                 assignshift==0,  assign==0, method + 0 == off
+     * c) Increment or decrement, translated to assignment add/subtr.
+     *                 assignshift==0,  assign==T, 
+     *         force_cpy == T
+     * d) Increment or decrement, translated to nomethod.
+     *                 assignshift==0,  assign==0, 
+     *         force_cpy == T
+     * e) Assignment form translated to nomethod.
+     *                 assignshift==1,  assign==T, method + 1 != off
+     *         force_cpy == T
+     */
+    /* off is method, method+assignshift, or a result of opcode substitution.
+     * In the latter case assignshift==0, so only notfound case is important.
+     */
+  if (( (method + assignshift == off)
+       && (assign || (method == inc_amg) || (method == dec_amg)))
+      || force_cpy)
+    RvDEEPCP(left);
   {
     dSP;
     BINOP myop;
index cc7da89..32d4692 100644 (file)
@@ -23,6 +23,7 @@ $tick = "auto" unless defined $tick;
 $unctrl = 'quote' unless defined $unctrl;
 $subdump = 1;
 $dumpReused = 0 unless defined $dumpReused;
+$bareStringify = 1 unless defined $bareStringify;
 
 sub main::dumpValue {
   local %address;
@@ -50,6 +51,10 @@ sub stringify {
 
        return 'undef' unless defined $_ or not $printUndef;
        return $_ . "" if ref \$_ eq 'GLOB';
+       $_ = &{'overload::StrVal'}($_) 
+         if $bareStringify and ref $_ 
+           and defined %overload:: and defined &{'overload::StrVal'};
+       
        if ($tick eq 'auto') {
          if (/[\000-\011\013-\037\177]/) {
            $tick = '"';
@@ -110,7 +115,7 @@ sub unwrap {
     return if $DB::signal;
     local($v) = shift ; 
     local($s) = shift ; # extra no of spaces
-    local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
+    local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
     local($tHashDepth,$tArrayDepth) ;
 
     $sp = " " x $s ;
@@ -118,9 +123,11 @@ sub unwrap {
 
     # Check for reused addresses
     if (ref $v) { 
-      ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
+      my $val = $v;
+      $val = &{'overload::StrVal'}($v) 
+       if defined %overload:: and defined &{'overload::StrVal'};
+      ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; 
       if (!$dumpReused && defined $address) { 
-       ($type) = $v =~ /=(.*?)\([^=]+$/ ;
        $address{$address}++ ;
        if ( $address{$address} > 1 ) { 
          print "${sp}-> REUSED_ADDRESS\n" ; 
index dfcdb02..43fef8a 100644 (file)
@@ -62,7 +62,10 @@ sub OverloadedStringify {
   my $package = shift;
   $package = ref $package if ref $package;
   #$package->can('(""')
-  ov_method mycan($package, '(""'), $package;
+  ov_method mycan($package, '(""'), $package
+    or ov_method mycan($package, '(0+'), $package
+    or ov_method mycan($package, '(bool'), $package
+    or ov_method mycan($package, '(nomethod'), $package;
 }
 
 sub Method {
@@ -108,6 +111,18 @@ sub mycan {                                # Real can would leave stubs.
              'qr'        => 0x10000,
             );
 
+%ops = ( with_assign     => "+ - * / % ** << >> x .",
+        assign           => "+= -= *= /= %= **= <<= >>= x= .=",
+        str_comparison   => "< <= >  >= == !=",
+        '3way_comparison'=> "<=> cmp",
+        num_comparison   => "lt le gt ge eq ne",
+        binary           => "& | ^",
+        unary            => "neg ! ~",
+        mutators         => '++ --',
+        func             => "atan2 cos sin exp abs log sqrt",
+        conversion       => 'bool "" 0+',
+        special          => 'nomethod fallback =');
+
 sub constant {
   # Arguments: what, sub
   while (@_) {
@@ -220,7 +235,8 @@ the arguments are reversed.
 
 the current operation is an assignment variant (as in
 C<$a+=7>), but the usual function is called instead.  This additional
-information can be used to generate some optimizations.
+information can be used to generate some optimizations.  Compare
+L<Calling Conventions for Mutators>.
 
 =back
 
@@ -230,9 +246,67 @@ Unary operation are considered binary operations with the second
 argument being C<undef>.  Thus the functions that overloads C<{"++"}>
 is called with arguments C<($a,undef,'')> when $a++ is executed.
 
+=head2 Calling Conventions for Mutators
+
+Two types of mutators have different calling conventions:
+
+=over
+
+=item C<++> and C<-->
+
+The routines which implement these operators are expected to actually
+I<mutate> their arguments.  So, assuming that $obj is a reference to a
+number,
+
+  sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}
+
+is an appropriate implementation of overloaded C<++>.  Note that
+
+  sub incr { ++$ {$_[0]} ; shift }
+
+is OK if used with preincrement and with postincrement. (In the case
+of postincrement a copying will be performed, see L<Copy Constructor>.)
+
+=item C<x=> and other assignment versions
+
+There is nothing special about these methods.  They may change the
+value of their arguments, and may leave it as is.  The result is going
+to be assigned to the value in the left-hand-side if different from
+this value.
+
+This allows for the same method to be used as averloaded C<+=> and
+C<+>.  Note that this is I<allowed>, but not recommended, since by the
+semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
+if C<+=> is not overloaded.
+
+=back
+
+B<Warning.>  Due to the presense of assignment versions of operations,
+routines which may be called in assignment context may create 
+self-referencial structures.  Currently Perl will not free self-referential 
+structures until cycles are C<explicitly> broken.  You may get problems
+when traversing your structures too.
+
+Say, 
+
+  use overload '+' => sub { bless [ \$_[0], \$_[1] ] };
+
+is asking for trouble, since for code C<$obj += $foo> the subroutine
+is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, 
+\$foo]>.  If using such a subroutine is an important optimization, one
+can overload C<+=> explicitly by a non-"optimized" version, or switch
+to non-optimized version if C<not defined $_[2]> (see 
+L<Calling Conventions for Binary Operations>).
+
+Even if no I<explicit> assignment-variants of operators are present in
+the script, they may be generated by the optimizer.  Say, C<",$obj,"> or
+C<',' . $obj . ','> may be both optimized to
+
+  my $tmp = ',' . $obj;    $tmp .= ',';
+
 =head2 Overloadable Operations
 
-The following symbols can be specified in C<use overload>:
+The following symbols can be specified in C<use overload> directive:
 
 =over 5
 
@@ -247,6 +321,10 @@ the assignment variant is not available.  Methods for operations "C<+>",
 increment and decrement methods.  The operation "C<->" can be used to
 autogenerate missing methods for unary minus or C<abs>.
 
+See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and
+L<"Calling Conventions for Binary Operations">) for details of these
+substitutions.
+
 =item * I<Comparison operations>
 
     "<",  "<=", ">",  ">=", "==", "!=", "<=>",
@@ -298,7 +376,23 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>.
 
 =back
 
-See L<"Fallback"> for an explanation of when a missing method can be autogenerated.
+See L<"Fallback"> for an explanation of when a missing method can be
+autogenerated.
+
+A computer-readable form of the above table is available in the hash
+%overload::ops, with values being space-separated lists of names:
+
+ with_assign     => '+ - * / % ** << >> x .',
+ assign                  => '+= -= *= /= %= **= <<= >>= x= .=',
+ str_comparison          => '< <= > >= == !=',
+ '3way_comparison'=> '<=> cmp',
+ num_comparison          => 'lt le gt ge eq ne',
+ binary                  => '& | ^',
+ unary           => 'neg ! ~',
+ mutators        => '++ --',
+ func            => 'atan2 cos sin exp abs log sqrt',
+ conversion      => 'bool "" 0+',
+ special         => 'nomethod fallback ='
 
 =head2 Inheritance and overloading
 
@@ -401,15 +495,15 @@ to a reference that shares its object with some other reference, such
 as
 
        $a=$b; 
-       $a++;
+       ++$a;
 
 To make this change $a and not change $b, a copy of C<$$a> is made,
 and $a is assigned a reference to this new object.  This operation is
-done during execution of the C<$a++>, and not during the assignment,
+done during execution of the C<++$a>, and not during the assignment,
 (so before the increment C<$$a> coincides with C<$$b>).  This is only
-done if C<++> is expressed via a method for C<'++'> or C<'+='>.  Note
-that if this operation is expressed via C<'+'> a nonmutator, i.e., as
-in
+done if C<++> is expressed via a method for C<'++'> or C<'+='> (or
+C<nomethod>).  Note that if this operation is expressed via C<'+'>
+a nonmutator, i.e., as in
 
        $a=$b; 
        $a=$a+1;
@@ -443,6 +537,9 @@ C<'='> was overloaded with C<\&clone>.
 
 =back
 
+Same behaviour is triggered by C<$b = $a++>, which is consider a synonim for
+C<$b = $a; ++$a>.
+
 =head1 MAGIC AUTOGENERATION
 
 If a method for an operation is not found, and the value for  C<"fallback"> is
@@ -499,7 +596,7 @@ value is a scalar and not a reference.
 
 =back
 
-=head1 WARNING
+=head1 Losing overloading
 
 The restriction for the comparison operation is that even if, for example,
 `C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
@@ -661,6 +758,416 @@ behavior by defining your own copy constructor (see L<"Copy Constructor">).
 It is expected that arguments to methods that are not explicitly supposed
 to be changed are constant (but this is not enforced).
 
+=head1 Metaphor clash
+
+One may wonder why the semantic of overloaded C<=> is so counterintuive.
+If it I<looks> counterintuive to you, you are subject to a metaphor 
+clash.  
+
+Here is a Perl object metaphor:
+
+I<  object is a reference to blessed data>
+
+and an arithmetic metaphor:
+
+I<  object is a thing by itself>.
+
+The I<main> problem of overloading C<=> is the fact that these metaphors
+imply different actions on the assignment C<$a = $b> if $a and $b are
+objects.  Perl-think implies that $a becomes a reference to whatever
+$b was referencing.  Arithmetic-think implies that the value of "object"
+$a is changed to become the value of the object $b, preserving the fact
+that $a and $b are separate entities.
+
+The difference is not relevant in the absence of mutators.  After
+a Perl-way assignment an operation which mutates the data referenced by $a
+would change the data referenced by $b too.  Effectively, after 
+C<$a = $b> values of $a and $b become I<indistinguishable>.
+
+On the other hand, anyone who has used algebraic notation knows the 
+expressive power of the arithmetic metaphor.  Overloading works hard
+to enable this metaphor while preserving the Perlian way as far as
+possible.  Since it is not not possible to freely mix two contradicting
+metaphors, overloading allows the arithmetic way to write things I<as
+far as all the mutators are called via overloaded access only>.  The
+way it is done is described in L<Copy Constructor>.
+
+If some mutator methods are directly applied to the overloaded values,
+one may need to I<explicitly unlink> other values which references the 
+same value:
+
+    $a = new Data 23;
+    ...
+    $b = $a;           # $b is "linked" to $a
+    ...
+    $a = $a->clone;    # Unlink $b from $a
+    $a->increment_by(4);
+
+Note that overloaded access makes this transparent:
+
+    $a = new Data 23;
+    $b = $a;           # $b is "linked" to $a
+    $a += 4;           # would unlink $b automagically
+
+However, it would not make
+
+    $a = new Data 23;
+    $a = 4;            # Now $a is a plain 4, not 'Data'
+
+preserve "objectness" of $a.  But Perl I<has> a way to make assignments
+to an object do whatever you want.  It is just not the overload, but
+tie()ing interface (see L<perlfunc/tie>).  Adding a FETCH() method
+which returns the object itself, and STORE() method which changes the 
+value of the object, one can reproduce the arithmetic metaphor in its
+completeness, at least for variables which were tie()d from the start.
+
+(Note that a workaround for a bug may be needed, see L<"BUGS">.)
+
+=head1 Cookbook
+
+Please add examples to what follows!
+
+=head2 Two-face scalars
+
+Put this in F<two_face.pm> in your Perl library directory:
+
+  package two_face;            # Scalars with separate string and
+                                # numeric values.
+  sub new { my $p = shift; bless [@_], $p }
+  use overload '""' => \&str, '0+' => \&num, fallback => 1;
+  sub num {shift->[1]}
+  sub str {shift->[0]}
+
+Use it as follows:
+
+  require two_face;
+  my $seven = new two_face ("vii", 7);
+  printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
+  print "seven contains `i'\n" if $seven =~ /i/;
+
+(The second line creates a scalar which has both a string value, and a
+numeric value.)  This prints:
+
+  seven=vii, seven=7, eight=8
+  seven contains `i'
+
+=head2 Symbolic calculator
+
+Put this in F<symbolic.pm> in your Perl library directory:
+
+  package symbolic;            # Primitive symbolic calculator
+  use overload nomethod => \&wrap;
+
+  sub new { shift; bless ['n', @_] }
+  sub wrap {
+    my ($obj, $other, $inv, $meth) = @_;
+    ($obj, $other) = ($other, $obj) if $inv;
+    bless [$meth, $obj, $other];
+  }
+
+This module is very unusual as overloaded modules go: it does not
+provide any usual overloaded operators, instead it provides the L<Last
+Resort> operator C<nomethod>.  In this example the corresponding
+subroutine returns an object which encupsulates operations done over
+the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new
+symbolic 3> contains C<['+', 2, ['n', 3]]>.
+
+Here is an example of the script which "calculates" the side of
+circumscribed octagon using the above package:
+
+  require symbolic;
+  my $iter = 1;                        # 2**($iter+2) = 8
+  my $side = new symbolic 1;
+  my $cnt = $iter;
+  
+  while ($cnt--) {
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  print "OK\n";
+
+The value of $side is
+
+  ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]],
+                      undef], 1], ['n', 1]]
+
+Note that while we obtained this value using a nice little script,
+there is no simple way to I<use> this value.  In fact this value may
+be inspected in debugger (see L<perldebug>), but ony if
+C<bareStringify> B<O>ption is set, and not via C<p> command.
+
+If one attempts to print this value, then the overloaded operator
+C<""> will be called, which will call C<nomethod> operator.  The
+result of this operator will be stringified again, but this result is
+again of type C<symbolic>, which will lead to an infinite loop.
+
+Add a pretty-printer method to the module F<symbolic.pm>:
+
+  sub pretty {
+    my ($meth, $a, $b) = @{+shift};
+    $a = 'u' unless defined $a;
+    $b = 'u' unless defined $b;
+    $a = $a->pretty if ref $a;
+    $b = $b->pretty if ref $b;
+    "[$meth $a $b]";
+  } 
+
+Now one can finish the script by
+
+  print "side = ", $side->pretty, "\n";
+
+The method C<pretty> is doing object-to-string conversion, so it
+is natural to overload the operator C<""> using this method.  However,
+inside such a method it is not necessary to pretty-print the
+I<components> $a and $b of an object.  In the above subroutine
+C<"[$meth $a $b]"> is a catenation of some strings and components $a
+and $b.  If these components use overloading, the catenation operator
+will look for an overloaded operator C<.>, if not present, it will
+look for an overloaded operator C<"">.  Thus it is enough to use
+
+  use overload nomethod => \&wrap, '""' => \&str;
+  sub str {
+    my ($meth, $a, $b) = @{+shift};
+    $a = 'u' unless defined $a;
+    $b = 'u' unless defined $b;
+    "[$meth $a $b]";
+  } 
+
+Now one can change the last line of the script to
+
+  print "side = $side\n";
+
+which outputs
+
+  side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]]
+
+and one can inspect the value in debugger using all the possible
+methods.  
+
+Something is is still amiss: consider the loop variable $cnt of the
+script.  It was a number, not an object.  We cannot make this value of
+type C<symbolic>, since then the loop will not terminate.
+
+Indeed, to terminate the cycle, the $cnt should become false.
+However, the operator C<bool> for checking falsity is overloaded (this
+time via overloaded C<"">), and returns a long string, thus any object
+of type C<symbolic> is true.  To overcome this, we need a way to
+compare an object to 0.  In fact, it is easier to write a numeric
+conversion routine.
+
+Here is the text of F<symbolic.pm> with such a routine added (and
+slightly modifed str()):
+
+  package symbolic;            # Primitive symbolic calculator
+  use overload
+    nomethod => \&wrap, '""' => \&str, '0+' => \&num;
+
+  sub new { shift; bless ['n', @_] }
+  sub wrap {
+    my ($obj, $other, $inv, $meth) = @_;
+    ($obj, $other) = ($other, $obj) if $inv;
+    bless [$meth, $obj, $other];
+  }
+  sub str {
+    my ($meth, $a, $b) = @{+shift};
+    $a = 'u' unless defined $a;
+    if (defined $b) {
+      "[$meth $a $b]";
+    } else {
+      "[$meth $a]";
+    }
+  } 
+  my %subr = ( n => sub {$_[0]}, 
+              sqrt => sub {sqrt $_[0]}, 
+              '-' => sub {shift() - shift()},
+              '+' => sub {shift() + shift()},
+              '/' => sub {shift() / shift()},
+              '*' => sub {shift() * shift()},
+              '**' => sub {shift() ** shift()},
+            );
+  sub num {
+    my ($meth, $a, $b) = @{+shift};
+    my $subr = $subr{$meth} 
+      or die "Do not know how to ($meth) in symbolic";
+    $a = $a->num if ref $a eq __PACKAGE__;
+    $b = $b->num if ref $b eq __PACKAGE__;
+    $subr->($a,$b);
+  }
+
+All the work of numeric conversion is done in %subr and num().  Of
+course, %subr is not complete, it contains only operators used in teh
+example below.  Here is the extra-credit question: why do we need an
+explicit recursion in num()?  (Answer is at the end of this section.)
+
+Use this module like this:
+
+  require symbolic;
+  my $iter = new symbolic 2;   # 16-gon
+  my $side = new symbolic 1;
+  my $cnt = $iter;
+  
+  while ($cnt) {
+    $cnt = $cnt - 1;           # Mutator `--' not implemented
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  printf "%s=%f\n", $side, $side;
+  printf "pi=%f\n", $side*(2**($iter+2));
+
+It prints (without so many line breaks)
+
+  [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1]
+                         [n 1]] 2]]] 1]
+     [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912
+  pi=3.182598
+
+The above module is very primitive.  It does not implement
+mutator methods (C<++>, C<-=> and so on), does not do deep copying
+(not required without mutators!), and implements only those arithmetic
+operations which are used in the example.
+
+To implement most arithmetic operattions is easy, one should just use
+the tables of operations, and change the code which fills %subr to
+
+  my %subr = ( 'n' => sub {$_[0]} );
+  foreach my $op (split " ", $overload::ops{with_assign}) {
+    $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+  }
+  my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+  foreach my $op (split " ", "@overload::ops{ @bins }") {
+    $subr{$op} = eval "sub {shift() $op shift()}";
+  }
+  foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+    print "defining `$op'\n";
+    $subr{$op} = eval "sub {$op shift()}";
+  }
+
+Due to L<Calling Conventions for Mutators>, we do not need anything
+special to make C<+=> and friends work, except filling C<+=> entry of
+%subr, and defining a copy constructor (needed since Perl has no
+way to know that the implementation of C<'+='> does not mutate
+the argument, compare L<Copy Constructor>).
+
+To implement a copy constructor, add C<'=' => \&cpy> to C<use overload>
+line, and code (this code assumes that mutators change things one level
+deep only, so recursive copying is not needed):
+
+  sub cpy {
+    my $self = shift;
+    bless [@$self], ref $self;
+  }
+
+To make C<++> and C<--> work, we need to implement actual mutators, 
+either directly, or in C<nomethod>.  We continue to do things inside
+C<nomethod>, thus add
+
+    if ($meth eq '++' or $meth eq '--') {
+      @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+      return $obj;
+    }
+
+after the first line of wrap().  This is not a most effective 
+implementation, one may consider
+
+  sub inc { $_[0] = bless ['++', shift, 1]; }
+
+instead.
+
+As a final remark, note that one can fill %subr by
+
+  my %subr = ( 'n' => sub {$_[0]} );
+  foreach my $op (split " ", $overload::ops{with_assign}) {
+    $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+  }
+  my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+  foreach my $op (split " ", "@overload::ops{ @bins }") {
+    $subr{$op} = eval "sub {shift() $op shift()}";
+  }
+  foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+    $subr{$op} = eval "sub {$op shift()}";
+  }
+  $subr{'++'} = $subr{'+'};
+  $subr{'--'} = $subr{'-'};
+
+This finishes implementation of a primitive symbolic calculator in 
+50 lines of Perl code.  Since the numeric values of subexpressions 
+are not cached, the calculator is very slow.
+
+Here is the answer for the exercise: In the case of str(), we need no
+explicit recursion since the overloaded C<.>-operator will fall back
+to an existing overloaded operator C<"">.  Overloaded arithmetic
+operators I<do not> fall back to numeric conversion if C<fallback> is
+not explicitly requested.  Thus without an explicit recursion num()
+would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild
+the argument of num().
+
+If you wonder why defaults for conversion are different for str() and
+num(), note how easy it was to write the symbolic calculator.  This
+simplicity is due to an appropriate choice of defaults.  One extra
+note: due to teh explicit recursion num() is more fragile than sym():
+we need to explicitly check for the type of $a and $b.  If componets
+$a and $b happen to be of some related type, this may lead to problems.
+
+=head2 I<Really> symbolic calculator
+
+One may wonder why we call the above calculator symbolic.  The reason
+is that the actual calculation of the value of expression is postponed
+until the value is I<used>.
+
+To see it in action, add a method
+
+  sub STORE { 
+    my $obj = shift; 
+    $#$obj = 1; 
+    @$obj->[0,1] = ('=', shift);
+  }
+
+to the package C<symbolic>.  After this change one can do
+
+  my $a = new symbolic 3;
+  my $b = new symbolic 4;
+  my $c = sqrt($a**2 + $b**2);
+
+and the numeric value of $c becomes 5.  However, after calling
+
+  $a->STORE(12);  $b->STORE(5);
+
+the numeric value of $c becomes 13.  There is no doubt now that the module
+symbolic provides a I<symbolic> calculator indeed.
+
+To hide the rough edges under the hood, provide a tie()d interface to the
+package C<symbolic> (compare with L<Metaphor clash>).  Add methods
+
+  sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+  sub FETCH { shift }
+  sub nop {  }         # Around a bug
+
+(the bug is described in L<"BUGS">).  One can use this new interface as
+
+  tie $a, 'symbolic', 3;
+  tie $b, 'symbolic', 4;
+  $a->nop;  $b->nop;   # Around a bug
+
+  my $c = sqrt($a**2 + $b**2);
+
+Now numeric value of $c is 5.  After C<$a = 12; $b = 5> the numeric value
+of $c becomes 13.  To insulate the user of the module add a method
+
+  sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+
+Now
+
+  my ($a, $b);
+  symbolic->vars($a, $b);
+  my $c = sqrt($a**2 + $b**2);
+
+  $a = 3; $b = 4;
+  printf "c5  %s=%f\n", $c, $c;
+
+  $a = 12; $b = 5;
+  printf "c13  %s=%f\n", $c, $c;
+
+shows that the numeric value of $c follows changes to the values of $a
+and $b.
+
 =head1 AUTHOR
 
 Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>.
@@ -676,7 +1183,7 @@ this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
 is shown by debugger. The method C<()> corresponds to the C<fallback>
 key (in fact a presence of this method shows that this package has
 overloading enabled, and it is what is used by the C<Overloaded>
-function).
+function of module C<overload>).
 
 =head1 BUGS
 
@@ -689,9 +1196,21 @@ C<fallback> is present (possibly undefined). This may create
 interesting effects if some package is not overloaded, but inherits
 from two overloaded packages.
 
+Relation between overloading and tie()ing is broken.  Overloading is 
+triggered or not basing on the I<previous> class of tie()d value.
+
+This happens because the presence of overloading is checked too early, 
+before any tie()d access is attempted.  If the FETCH()ed class of the
+tie()d value does not change, a simple workaround is to access the value 
+immediately after tie()ing, so that after this call the I<previous> class
+coincides with the current one.
+
+B<Needed:> a way to fix this without a speed penalty.
+
 Barewords are not covered by overloaded string constants.
 
-This document is confusing.
+This document is confusing.  There are grammos and misleading language
+used in places.  It would seem a total rewrite is needed.
 
 =cut
 
index 67a6a6d..bad153c 100644 (file)
@@ -2,7 +2,7 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 1.03;
+$VERSION = 1.04;
 $header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -179,7 +179,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
                  recallCommand ShellBang pager tkRunning ornaments
                  signalLevel warnLevel dieLevel inhibit_exit
-                 ImmediateStop);
+                 ImmediateStop bareStringify);
 
 %optionVars    = (
                 hashDepth      => \$dumpvar::hashDepth,
@@ -191,6 +191,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                 undefPrint     => \$dumpvar::printUndef,
                 globPrint      => \$dumpvar::globPrint,
                 UsageOnly      => \$dumpvar::usageOnly,     
+                bareStringify  => \$dumpvar::bareStringify,
                 frame          => \$frame,
                 AutoTrace      => \$trace,
                 inhibit_exit   => \$inhibit_exit,
@@ -1823,6 +1824,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
     I<DumpPackages>:           dump symbol tables of packages;
     I<DumpReused>:             dump contents of \"reused\" addresses;
     I<quote>, I<HighBit>, I<undefPrint>:       change style of string dump;
+    I<bareStringify>:          Do not print the overload-stringified value;
   Option I<PrintRet> affects printing of return value after B<r> command,
          I<frame>    affects printing messages on entry and exit from subroutines.
          I<AutoTrace> affects printing messages on every possible breaking point.
index 05035c6..64ab7ab 100755 (executable)
@@ -436,6 +436,265 @@ test($b, "_<oups1
 >_");  # 134
 test($c, "bareword");  # 135
 
+{
+  package symbolic;            # Primitive symbolic calculator
+  use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
+      '=' => \&cpy, '++' => \&inc, '--' => \&dec;
+
+  sub new { shift; bless ['n', @_] }
+  sub cpy {
+    my $self = shift;
+    bless [@$self], ref $self;
+  }
+  sub inc { $_[0] = bless ['++', $_[0], 1]; }
+  sub dec { $_[0] = bless ['--', $_[0], 1]; }
+  sub wrap {
+    my ($obj, $other, $inv, $meth) = @_;
+    if ($meth eq '++' or $meth eq '--') {
+      @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+      return $obj;
+    }
+    ($obj, $other) = ($other, $obj) if $inv;
+    bless [$meth, $obj, $other];
+  }
+  sub str {
+    my ($meth, $a, $b) = @{+shift};
+    $a = 'u' unless defined $a;
+    if (defined $b) {
+      "[$meth $a $b]";
+    } else {
+      "[$meth $a]";
+    }
+  } 
+  my %subr = ( 'n' => sub {$_[0]} );
+  foreach my $op (split " ", $overload::ops{with_assign}) {
+    $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+  }
+  my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+  foreach my $op (split " ", "@overload::ops{ @bins }") {
+    $subr{$op} = eval "sub {shift() $op shift()}";
+  }
+  foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+    $subr{$op} = eval "sub {$op shift()}";
+  }
+  $subr{'++'} = $subr{'+'};
+  $subr{'--'} = $subr{'-'};
+  
+  sub num {
+    my ($meth, $a, $b) = @{+shift};
+    my $subr = $subr{$meth} 
+      or die "Do not know how to ($meth) in symbolic";
+    $a = $a->num if ref $a eq __PACKAGE__;
+    $b = $b->num if ref $b eq __PACKAGE__;
+    $subr->($a,$b);
+  }
+  sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+  sub FETCH { shift }
+  sub nop {  }         # Around a bug
+  sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+  sub STORE { 
+    my $obj = shift; 
+    $#$obj = 1; 
+    @$obj->[0,1] = ('=', shift);
+  }
+}
+
+{
+  my $foo = new symbolic 11;
+  my $baz = $foo++;
+  test( (sprintf "%d", $foo), '12');
+  test( (sprintf "%d", $baz), '11');
+  my $bar = $foo;
+  $baz = ++$foo;
+  test( (sprintf "%d", $foo), '13');
+  test( (sprintf "%d", $bar), '12');
+  test( (sprintf "%d", $baz), '13');
+  my $ban = $foo;
+  $baz = ($foo += 1);
+  test( (sprintf "%d", $foo), '14');
+  test( (sprintf "%d", $bar), '12');
+  test( (sprintf "%d", $baz), '14');
+  test( (sprintf "%d", $ban), '13');
+  $baz = 0;
+  $baz = $foo++;
+  test( (sprintf "%d", $foo), '15');
+  test( (sprintf "%d", $baz), '14');
+  test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+}
+
+{
+  my $iter = new symbolic 2;
+  my $side = new symbolic 1;
+  my $cnt = $iter;
+  
+  while ($cnt) {
+    $cnt = $cnt - 1;           # The "simple" way
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  my $pi = $side*(2**($iter+2));
+  test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+  test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+  my $iter = new symbolic 2;
+  my $side = new symbolic 1;
+  my $cnt = $iter;
+  
+  while ($cnt--) {
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  my $pi = $side*(2**($iter+2));
+  test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+  test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+  my ($a, $b);
+  symbolic->vars($a, $b);
+  my $c = sqrt($a**2 + $b**2);
+  $a = 3; $b = 4;
+  test( (sprintf "%d", $c), '5');
+  $a = 12; $b = 5;
+  test( (sprintf "%d", $c), '13');
+}
+
+{
+  package symbolic1;           # Primitive symbolic calculator
+  # Mutator inc/dec
+  use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
+
+  sub new { shift; bless ['n', @_] }
+  sub cpy {
+    my $self = shift;
+    bless [@$self], ref $self;
+  }
+  sub wrap {
+    my ($obj, $other, $inv, $meth) = @_;
+    if ($meth eq '++' or $meth eq '--') {
+      @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+      return $obj;
+    }
+    ($obj, $other) = ($other, $obj) if $inv;
+    bless [$meth, $obj, $other];
+  }
+  sub str {
+    my ($meth, $a, $b) = @{+shift};
+    $a = 'u' unless defined $a;
+    if (defined $b) {
+      "[$meth $a $b]";
+    } else {
+      "[$meth $a]";
+    }
+  } 
+  my %subr = ( 'n' => sub {$_[0]} );
+  foreach my $op (split " ", $overload::ops{with_assign}) {
+    $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+  }
+  my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+  foreach my $op (split " ", "@overload::ops{ @bins }") {
+    $subr{$op} = eval "sub {shift() $op shift()}";
+  }
+  foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+    $subr{$op} = eval "sub {$op shift()}";
+  }
+  $subr{'++'} = $subr{'+'};
+  $subr{'--'} = $subr{'-'};
+  
+  sub num {
+    my ($meth, $a, $b) = @{+shift};
+    my $subr = $subr{$meth} 
+      or die "Do not know how to ($meth) in symbolic";
+    $a = $a->num if ref $a eq __PACKAGE__;
+    $b = $b->num if ref $b eq __PACKAGE__;
+    $subr->($a,$b);
+  }
+  sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+  sub FETCH { shift }
+  sub nop {  }         # Around a bug
+  sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+  sub STORE { 
+    my $obj = shift; 
+    $#$obj = 1; 
+    @$obj->[0,1] = ('=', shift);
+  }
+}
+
+{
+  my $foo = new symbolic1 11;
+  my $baz = $foo++;
+  test( (sprintf "%d", $foo), '12');
+  test( (sprintf "%d", $baz), '11');
+  my $bar = $foo;
+  $baz = ++$foo;
+  test( (sprintf "%d", $foo), '13');
+  test( (sprintf "%d", $bar), '12');
+  test( (sprintf "%d", $baz), '13');
+  my $ban = $foo;
+  $baz = ($foo += 1);
+  test( (sprintf "%d", $foo), '14');
+  test( (sprintf "%d", $bar), '12');
+  test( (sprintf "%d", $baz), '14');
+  test( (sprintf "%d", $ban), '13');
+  $baz = 0;
+  $baz = $foo++;
+  test( (sprintf "%d", $foo), '15');
+  test( (sprintf "%d", $baz), '14');
+  test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+}
+
+{
+  my $iter = new symbolic1 2;
+  my $side = new symbolic1 1;
+  my $cnt = $iter;
+  
+  while ($cnt) {
+    $cnt = $cnt - 1;           # The "simple" way
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  my $pi = $side*(2**($iter+2));
+  test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+  test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+  my $iter = new symbolic1 2;
+  my $side = new symbolic1 1;
+  my $cnt = $iter;
+  
+  while ($cnt--) {
+    $side = (sqrt(1 + $side**2) - 1)/$side;
+  }
+  my $pi = $side*(2**($iter+2));
+  test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+  test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+  my ($a, $b);
+  symbolic1->vars($a, $b);
+  my $c = sqrt($a**2 + $b**2);
+  $a = 3; $b = 4;
+  test( (sprintf "%d", $c), '5');
+  $a = 12; $b = 5;
+  test( (sprintf "%d", $c), '13');
+}
+
+{
+  package two_face;            # Scalars with separate string and
+                                # numeric values.
+  sub new { my $p = shift; bless [@_], $p }
+  use overload '""' => \&str, '0+' => \&num, fallback => 1;
+  sub num {shift->[1]}
+  sub str {shift->[0]}
+}
+
+{
+  my $seven = new two_face ("vii", 7);
+  test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1),
+       'seven=vii, seven=7, eight=8');
+  test( scalar ($seven =~ /i/), '1')
+}
 
 # Last test is:
-sub last {135}
+sub last {173}