From: Ilya Zakharevich Date: Sat, 25 Jul 1998 21:28:16 +0000 (-0400) Subject: fixes for overloading bugs and docs, tweaked some X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ee239bfe47dc5d504cf50bb8f48401031aa791d7;p=p5sagit%2Fp5-mst-13.2.git fixes for overloading bugs and docs, tweaked some Message-Id: <199807260128.VAA10543@monk.mps.ohio-state.edu> Subject: [PATCH 5.004_76] better overloading p4raw-id: //depot/maint-5.005/perl@1677 --- diff --git a/Changes b/Changes index 9361b8a..5bca36a 100644 --- 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 --- 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; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index cc7da89..32d4692 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -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" ; diff --git a/lib/overload.pm b/lib/overload.pm index dfcdb02..43fef8a 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -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. =back @@ -230,9 +246,67 @@ Unary operation are considered binary operations with the second argument being C. 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 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.) + +=item C 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, 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 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 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 (see +L). + +Even if no I 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: +The following symbols can be specified in C 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. +See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and +L<"Calling Conventions for Binary Operations">) for details of these +substitutions. + =item * I "<", "<=", ">", ">=", "==", "!=", "<=>", @@ -298,7 +376,23 @@ see L>. =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). 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' should return a blessed reference, the autogenerated `C' @@ -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 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
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. + +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. The +way it is done is described in L. + +If some mutator methods are directly applied to the overloaded values, +one may need to I 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 a way to make assignments +to an object do whatever you want. It is just not the overload, but +tie()ing interface (see L). 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 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 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 operator C. In this example the corresponding +subroutine returns an object which encupsulates operations done over +the objects: C 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 this value. In fact this value may +be inspected in debugger (see L), but ony if +C Bption is set, and not via C

command. + +If one attempts to print this value, then the overloaded operator +C<""> will be called, which will call C operator. The +result of this operator will be stringified again, but this result is +again of type C, which will lead to an infinite loop. + +Add a pretty-printer method to the module F: + + 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 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 $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, since then the loop will not terminate. + +Indeed, to terminate the cycle, the $cnt should become false. +However, the operator C for checking falsity is overloaded (this +time via overloaded C<"">), and returns a long string, thus any object +of type C 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 with such a routine added (and +slightly modifed str()): + + package symbolic; # Primitive symbolic calculator + use overload + nomethod => \&wrap, '""' => \&str, '0+' => \# + + 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, 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). + +To implement a copy constructor, add C<'=' => \&cpy> to C +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. We continue to do things inside +C, 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 fall back to numeric conversion if C 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 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. + +To see it in action, add a method + + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } + +to the package C. 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 calculator indeed. + +To hide the rough edges under the hood, provide a tie()d interface to the +package C (compare with L). 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 EFE. @@ -676,7 +1183,7 @@ this overloading). Say, if C is overloaded, then the method C<(eq> is shown by debugger. The method C<()> corresponds to the C key (in fact a presence of this method shows that this package has overloading enabled, and it is what is used by the C -function). +function of module C). =head1 BUGS @@ -689,9 +1196,21 @@ C 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 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 class +coincides with the current one. + +B 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 diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 67a6a6d..bad153c 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -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 [I[B<=>I]] [IB<\">IB<\">] [IB]... I: dump symbol tables of packages; I: dump contents of \"reused\" addresses; I, I, I: change style of string dump; + I: Do not print the overload-stringified value; Option I affects printing of return value after B command, I affects printing messages on entry and exit from subroutines. I affects printing messages on every possible breaking point. diff --git a/t/pragma/overload.t b/t/pragma/overload.t index 05035c6..64ab7ab 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -436,6 +436,265 @@ test($b, "__"); # 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}