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>

5 files changed, 109 insertions, 17 deletions

diff --git a/gv.c b/gv.c
index 5ffa11b02e..2e2bc193d5 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 ec874ec8d7..a07e91513e 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 fb0a2d76c0..ba7308f289 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<overload>.
 
+=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<can>
+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 e4e00ce948..8710b5418d 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 9c897c31dc..42d045741d 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}