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>

diff --git a/gv.c b/gv.c
index 5ffa11b..2e2bc19 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 e4e00ce..8710b54 100644 (file)
--- 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 (executable)
--- 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}