From a9bc755754f0db5e848e65dfd2e63a96af50ffd4 Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Sun, 12 Jan 1997 16:22:47 -0500 Subject: [PATCH] Fix overloading via inherited autoloaded functions Subject: Re: overloading broken in _20, or am I dense? Randal Schwartz writes: > > > This code works fine with _11, but breaks with _20. Did I mess > something up? Or is something seriously broken in _20? (This is at > the heart of making LWP work again.) > > #!/home/merlyn/test/bin/perl > > BEGIN { > package A; > > sub as_string { > shift->{"string"}; > } > } > > BEGIN { > package B; > @ISA = qw(A); > use overload ('""' => 'as_string', 'fallback' => 1); > > sub new { > my $self = bless {}, shift; > $self->{"string"} = shift; > $self; > } > } > > $thing = new B "newbie"; > ## print $thing->as_string; > print "$thing"; The patch below updates the following files: gv.c pp.c t/op/overload.t pod/perldiag.pod lib/overload.pm It fixes the above bug, another bug with autoloaded overloading subroutines via inheritance (grok!), adds a way to do gv_findmeth without creating import stubs (undocumented yet - give -1 as level), and sneaks in a long-awaited ;-) feature *{\&subr}. Final implementation of overloading does not use the above feature, but I know a lot of uses for debugging. Anyway, feel free to remove the first chunk of the patch if you feel offended by the above feature. Tested with _17. Enjoy, p5p-msgid: <199701131022.FAA22830@monk.mps.ohio-state.edu> --- gv.c | 59 +++++++++++++++++++++++++++++++++++++++++++---------- lib/overload.pm | 30 ++++++++++++++++++++++++--- pod/perldiag.pod | 11 ++++++++++ pp.c | 2 ++ t/pragma/overload.t | 24 +++++++++++++++++++--- 5 files changed, 109 insertions(+), 17 deletions(-) diff --git a/gv.c b/gv.c index 5ffa11b..2e2bc19 100644 --- a/gv.c +++ b/gv.c @@ -129,7 +129,7 @@ STRLEN len; I32 level; { AV* av; - GV* topgv; + GV* topgv = NULL; GV* gv; GV** gvp; HV* lastchance; @@ -137,12 +137,14 @@ I32 level; if (!stash) return 0; - if (level > 100) + if ((level > 100) || (level < -100)) croak("Recursive inheritance detected"); - gvp = (GV**)hv_fetch(stash, name, len, TRUE); + gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); + if (!gvp) goto recurse; + topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); @@ -162,6 +164,7 @@ I32 level; } /* Now cv = 0, and there is no cv in topgv. */ + recurse: gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { SV** svp = AvARRAY(av); @@ -175,19 +178,19 @@ I32 level; SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len, level + 1); - if (gv) { + gv = gv_fetchmeth(basestash, name, len, level + (level >= 0 ? 1 : -1)); + if (gv && topgv) { GvCV(topgv) = GvCV(gv); /* cache the CV */ GvCVGEN(topgv) = sub_generation; /* valid for now */ SvREFCNT_inc(GvCV(gv)); return gv; - } + } else if (gv) return gv; } } - if (!level) { + if ((level == 0) || (level == -1)) { /* topgv is present. */ if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { - if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { + if (gv = gv_fetchmeth(lastchance, name, len, level + (level >= 0 ? 1 : -1))) { GvCV(topgv) = GvCV(gv); /* cache the CV */ GvCVGEN(topgv) = sub_generation; /* valid for now */ SvREFCNT_inc(GvCV(gv)); @@ -968,8 +971,42 @@ HV* stash; *buf = '('; /* A cooky: "(". */ strcpy(buf + 1, cp); - gv = gv_fetchmeth(stash, buf, strlen(buf), 0); /* fills the stash! */ - if(gv && (cv = GvCV(gv))) filled = 1; + DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", + cp, HvNAME(stash)) ); + gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */ + if(gv && (cv = GvCV(gv))) { + char *name = buf; + if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") + && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + /* GvSV contains the name of the method. */ + GV *ngv; + + DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", + SvPV(GvSV(gv), na), cp, HvNAME(stash)) ); + if (SvPOK(GvSV(gv)) + && (ngv = gv_fetchmethod(stash, SvPVX(GvSV(gv))))) { + name = SvPVX(GvSV(gv)); + cv = GvCV(gv = ngv); + } else { + /* Can be an import stub (created by `can'). */ + if (GvCVGEN(gv)) { + croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } else + croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } + /* If the sub is only a stub then we may have a gv to AUTOLOAD */ + gv = (GV*)*hv_fetch(GvSTASH(gv), name, strlen(name), TRUE); + cv = GvCV(gv); + } + DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", + cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } #endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } @@ -1255,7 +1292,7 @@ int flags; case dec_amg: SvSetSV(left,res); return left; case not_amg: -ans=!SvOK(res); break; + ans=!SvOK(res); break; } return ans? &sv_yes: &sv_no; } else if (method==copy_amg) { diff --git a/lib/overload.pm b/lib/overload.pm index ec874ec..a07e915 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -14,7 +14,8 @@ sub OVERLOAD { } else { $sub = $arg{$_}; if (not ref $sub and $sub !~ /::/) { - $sub = "${'package'}::$sub"; + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; } #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; *{$package . "::(" . $_} = \&{ $sub }; @@ -49,16 +50,28 @@ sub Overloaded { $package->can('()'); } +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + return $sub if $sub ne \&nil; + return shift->can($ {*$globref}); +} + sub OverloadedStringify { my $package = shift; $package = ref $package if ref $package; - $package->can('(""') + #$package->can('(""') + ov_method mycan($package, '(""'), $package; } sub Method { my $package = shift; $package = ref $package if ref $package; - $package->can('(' . shift) + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; } sub AddrRef { @@ -76,6 +89,17 @@ sub StrVal { "$_[0]"; } +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + return \*{$package . "::$meth"} if defined &{$package . "::$meth"}; + my $p; + foreach $p (@{"${package}::ISA"}) { + my $out = mycan($p, $meth); + return $out if $out; + } + return undef; +} + 1; __END__ diff --git a/pod/perldiag.pod b/pod/perldiag.pod index fb0a2d7..ba7308f 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1487,6 +1487,17 @@ will extend the buffer and zero pad the new area. (F) An attempt was made to use an entry in an overloading table that somehow no longer points to a valid method. See L. +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importing stubs. +Stubs should never be implicitely created, but explicit calls to C +may break this. + +=item Cannot resolve method `%s' overloading `%s' in package `s' + +(P) Internal error trying to resolve overloading specified by a method +name (as opposed to a subroutine reference). + =item Operator or semicolon missing before %s (S) You used a variable or subroutine call where the parser was diff --git a/pp.c b/pp.c index e4e00ce..8710b54 100644 --- a/pp.c +++ b/pp.c @@ -119,6 +119,8 @@ PP(pp_rv2gv) GvIOp(gv) = (IO *)sv; SvREFCNT_inc(sv); sv = (SV*) gv; + } else if (SvTYPE(sv) == SVt_PVCV) { + sv = (SV*) CvGV(sv); } else if (SvTYPE(sv) != SVt_PVGV) DIE("Not a GLOB reference"); } diff --git a/t/pragma/overload.t b/t/pragma/overload.t index 9c897c3..42d0457 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -291,7 +291,7 @@ test($@ =~ /no method found/); # 96 sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; goto &{"Oscalar::$AUTOLOAD"}}; -eval "package Oscalar; use overload '~' => 'comple'"; +eval "package Oscalar; sub comple; use overload '~' => 'comple'"; $na = eval { ~$a }; # Hash was not updated test($@ =~ /no method found/); # 97 @@ -299,6 +299,7 @@ test($@ =~ /no method found/); # 97 bless \$x, Oscalar; $na = eval { ~$a }; # Hash updated +warn "`$na', $@" if $@; test !$@; # 98 test($na eq '_!_xx_!_'); # 99 @@ -315,7 +316,7 @@ print $@; test !$@; # 101 test($na eq '_!_xx_!_'); # 102 -eval "package Oscalar; use overload '>>' => 'rshft'"; +eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; $na = eval { $aI >> 1 }; # Hash was not updated test($@ =~ /no method found/); # 103 @@ -330,6 +331,7 @@ print $@; test !$@; # 104 test($na eq '_!_xx_!_'); # 105 +# warn overload::Method($a, '0+'), "\n"; test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 test (overload::Overloaded($aI)); # 108 @@ -341,5 +343,21 @@ test (! defined overload::Method($a, '<')); # 111 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 +# Check overloading by methods (specified deep in the ISA tree). +{ + package OscalarII; + @ISA = 'OscalarI'; + sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} + eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; +} + +$aaII = "087"; +$aII = \$aaII; +bless $aII, 'OscalarII'; +bless \$fake, 'OscalarI'; # update the hash +test(($aI | 3) eq '_<<_xx_<<_'); # 114 +# warn $aII << 3; +test(($aII << 3) eq '_<<_087_<<_'); # 115 + # Last test is: -sub last {113} +sub last {115} -- 2.7.4