Make overloaded classes inherit fallback

Before this commit, only classes that had no overloading defined could
inherit the fallback from other classes.  If a subclass wanted to
override a single overload setting, it would have to specify the fall-
back value explicitly, to avoid implying fallback=>undef.

We do this by separating the fallback value from overloadedness
itself, so it is possible to have a class that is overloaded, but with
no fallback value.

Previously, the ‘()’ stash entry was used for two purposes.  It had a
sub in it so it could be found using usual method lookup mechanims.
The failure to find any such method would be taken for efficiency’s
sake to mean that there was no overloaded, and the search for methods
could end early.  The scalar slot contained the fallback entry itself.

To preserve the effiency, we still use &{"()"} to indicate that there
is overloadedness.

Fallback now uses its own entry, named ‘(fallback’.  Since it
has to be special-cased anyway, there is no need to add it to
regen/overload.pl.

diff --git a/gv.c b/gv.c
index 00aaade..3c6e5b0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2283,24 +2283,31 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     int filled = 0, have_ovl = 0;
     int i, lim = 1;
 
-    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
+    /* The first key in PL_AMG_names is the overloadedness indicator, which
+       allows us to skip overloading entries for non-overloaded classes. */
 
     /* Try to find via inheritance. */
     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
-    SV * const sv = gv ? GvSV(gv) : NULL;
     CV* cv;
 
     if (!gv)
        lim = DESTROY_amg;              /* Skip overloading entries. */
-#ifdef PERL_DONT_CREATE_GVSV
-    else if (!sv) {
+
+    else {
+      
+      /* The "fallback" key is special-cased here, being absent from the
+        list in PL_AMG_names. */
+
+      SV *sv;
+      gv = gv_fetchmeth_pvn(stash, "(fallback", 9, -1, 0);
+
+      if (!gv || !(sv = GvSV(gv)))
        NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
-    }
-#endif
-    else if (SvTRUE(sv))
+      else if (SvTRUE(sv))
        amt.fallback=AMGfallYES;
-    else if (SvOK(sv))
+      else if (SvOK(sv))
        amt.fallback=AMGfallNEVER;
+    }
 
     for (i = 1; i < lim; i++)
        amt.table[i] = NULL;

diff --git a/lib/overload.pm b/lib/overload.pm
index fbb04e5..f270310 100644 (file)
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -32,11 +32,13 @@ sub OVERLOAD {
   my %arg = @_;
   my ($sub, $fb);
   $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
-  $fb = ${$package . "::()"}; # preserve old fallback value RT#68196
   *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
   for (keys %arg) {
     if ($_ eq 'fallback') {
-      $fb = $arg{$_};
+      for my $sym (*{$package . "::(fallback"}) {
+       *$sym = \&nil; # Make it findable via fetchmethod.
+       $$sym = $arg{$_};
+      }
     } else {
       warnings::warnif("overload arg '$_' is invalid")
         unless $ops_seen{$_};
@@ -49,7 +51,6 @@ sub OVERLOAD {
       *{$package . "::(" . $_} = \&{ $sub };
     }
   }
-  ${$package . "::()"} = $fb; # Make it findable too (fallback only).
 }
 
 sub import {
@@ -64,11 +65,7 @@ sub unimport {
   ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
   shift;
   for (@_) {
-    if ($_ eq 'fallback') {
-      undef $ {$package . "::()"};
-    } else {
       delete $ {$package . "::"}{"(" . $_};
-    }
   }
 }
 
@@ -936,10 +933,10 @@ be called to implement operation C<+> for an object in package C<A>.
 
 =back
 
-Note that since the value of the C<fallback> key is not a subroutine,
-its inheritance is not governed by the above rules.  In the current
-implementation, the value of C<fallback> in the first overloaded
-ancestor is used, but this is accidental and subject to change.
+Note that in Perl version prior to 5.18 inheritance of the C<fallback> key
+was not governed by the above rules.  The value of C<fallback> in the first 
+overloaded ancestor was used.  This was fixed in 5.18 to follow the usual
+rules of inheritance.
 
 =head2 Run-time Overloading
 
@@ -1681,6 +1678,9 @@ The symbol table is filled with names looking like line-noise.
 
 =item *
 
+This bug was fixed in Perl 5.18, but may still trip you up if you are using
+older versions:
+
 For the purpose of inheritance every overloaded package behaves as if
 C<fallback> is present (possibly undefined).  This may create
 interesting effects if some package is not overloaded, but inherits

diff --git a/lib/overload.t b/lib/overload.t
index 8ada616..a622cf7 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl' }
-plan tests => 5048;
+plan tests => 5050;
 
 use Scalar::Util qw(tainted);
 
@@ -2267,6 +2267,30 @@ is "$a", "arakas",
     'no overload "fallback" does not stop overload from working';
 ok !eval { () = $a eq 'mpizeli'; 1 },
     'no overload "fallback" resets fallback to undef on overloaded class';
+{ package ent; use overload fallback => 0, abs => sub{};
+  our@ISA = 'huorn';
+  package huorn;
+  use overload fallback => 1;
+  package ent;
+  no overload "fallback"; # disable previous declaration
+}
+$a = bless [], ent::;
+is eval {"$a"}, overload::StrVal($a),
+    'no overload undoes fallback declaration completetly'
+ or diag $@;
+
+# inherited fallback
+{
+ package pervyy;
+ our @ISA = 'vtoryy';
+ use overload "abs" =>=> sub {};
+ package vtoryy;
+ use overload fallback => 1, 'sin' =>=> sub{}
+}
+$a = bless [], pervyy::;
+is eval {"$a"}, overload::StrVal($a),
+ 'fallback is inherited by classes that have their own overloading'
+ or diag $@;
 
 { # undefining the overload stash -- KEEP THIS TEST LAST
     package ant;