Initial implementation of subclassing, via :isa class attribute

MANIFEST

@@ -5644,6 +5644,7 @@ t/class/class.t			See if class declarations work
 t/class/construct.t		See if class constructors work
 t/class/destruct.t		See if class destruction works
 t/class/field.t			See if class field declarations work
+t/class/inherit.t		See if class inheritance works
 t/class/method.t		See if class method declarations work
 t/class/phasers.t		See if class phaser blocks work
 t/cmd/elsif.t			See if else-if works

class.c

@@ -44,6 +44,46 @@ Perl_newSVobject(pTHX_ Size_t fieldcount)
     return sv;
 }
 
+#define make_instance_fields(stash, instance)  S_make_instance_fields(aTHX_ stash, instance)
+static void S_make_instance_fields(pTHX_ HV *stash, SV *instance)
+{
+    struct xpvhv_aux *aux = HvAUX(stash);
+
+    if(aux->xhv_class_superclass) {
+        make_instance_fields(aux->xhv_class_superclass, instance);
+    }
+
+    SV **fields = ObjectFIELDS(instance);
+
+    PADNAMELIST *fieldnames = aux->xhv_class_fields;
+
+    for(U32 i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) {
+        PADNAME *pn = PadnamelistARRAY(fieldnames)[i];
+        PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix;
+
+        SV *val = NULL;
+
+        switch(PadnamePV(pn)[0]) {
+            case '$':
+                val = newSV(0);
+                break;
+
+            case '@':
+                val = (SV *)newAV();
+                break;
+
+            case '%':
+                val = (SV *)newHV();
+                break;
+
+            default:
+                NOT_REACHED;
+        }
+
+        fields[fieldix] = val;
+    }
+}
+
 XS(injected_constructor);
 XS(injected_constructor)
 {
@@ -83,36 +123,9 @@ XS(injected_constructor)
     SvOBJECT_on(instance);
     SvSTASH_set(instance, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
 
-    SV *self = sv_2mortal(newRV_noinc(instance));
-
-    SV **fields = ObjectFIELDS(instance);
-
-    /* create fields */
-    for(PADOFFSET fieldix = 0; fieldix < aux->xhv_class_next_fieldix; fieldix++) {
-        PADNAME *pn = PadnamelistARRAY(aux->xhv_class_fields)[fieldix];
-        assert(PadnameFIELDINFO(pn)->fieldix == fieldix);
-
-        SV *val = NULL;
+    make_instance_fields(stash, instance);
 
-        switch(PadnamePV(pn)[0]) {
-            case '$':
-                val = newSV(0);
-                break;
-
-            case '@':
-                val = (SV *)newAV();
-                break;
-
-            case '%':
-                val = (SV *)newHV();
-                break;
-
-            default:
-                NOT_REACHED;
-        }
-
-        fields[fieldix] = val;
-    }
+    SV *self = sv_2mortal(newRV_noinc(instance));
 
     if(aux->xhv_class_adjust_blocks) {
         CV **cvp = (CV **)AvARRAY(aux->xhv_class_adjust_blocks);
@@ -190,8 +203,8 @@ PP(pp_methstart)
             namehek);
     }
 
-    /* TODO: When we implement inheritence we'll have to do something fancier here */
-    if(CvSTASH(curcv) != SvSTASH(rv))
+    if(CvSTASH(curcv) != SvSTASH(rv) &&
+        !sv_derived_from_hv(self, CvSTASH(curcv)))
         croak("Cannot invoke a method of %" HvNAMEf_QUOTEDPREFIX " on an instance of %" HvNAMEf_QUOTEDPREFIX,
             HvNAMEfARG(CvSTASH(curcv)), HvNAMEfARG(SvSTASH(rv)));
 
@@ -267,20 +280,138 @@ Perl_class_setup_stash(pTHX_ HV *stash)
      *   DOES method
      */
 
-    HvAUX(stash)->xhv_class_adjust_blocks = NULL;
-    HvAUX(stash)->xhv_class_fields        = NULL;
-    HvAUX(stash)->xhv_class_next_fieldix  = 0;
+    struct xpvhv_aux *aux = HvAUX(stash);
+    aux->xhv_class_superclass    = NULL;
+    aux->xhv_class_adjust_blocks = NULL;
+    aux->xhv_class_fields        = NULL;
+    aux->xhv_class_next_fieldix  = 0;
 
-    HvAUX(stash)->xhv_aux_flags |= HvAUXf_IS_CLASS;
+    aux->xhv_aux_flags |= HvAUXf_IS_CLASS;
 
     SAVEDESTRUCTOR_X(invoke_class_seal, stash);
 }
 
+#define split_package_ver(value, pkgname, pkgversion)  S_split_package_ver(aTHX_ value, pkgname, pkgversion)
+static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion)
+{
+    const char *start = SvPVX(value),
+               *p     = start,
+               *end   = start + SvCUR(value);
+
+    while(*p && !isSPACE_utf8_safe(p, end))
+        p += UTF8SKIP(p);
+
+    sv_setpvn(pkgname, start, p - start);
+    if(SvUTF8(value))
+        SvUTF8_on(pkgname);
+
+    while(*p && isSPACE_utf8_safe(p, end))
+        p += UTF8SKIP(p);
+
+    if(*p) {
+        /* scan_version() gets upset about trailing content. We need to extract
+         * exactly what it wants
+         */
+        start = p;
+        if(*p == 'v')
+            p++;
+        while(*p && strchr("0123456789._", *p))
+            p++;
+        SV *tmpsv = newSVpvn(start, p - start);
+        SAVEFREESV(tmpsv);
+
+        scan_version(SvPVX(tmpsv), pkgversion, FALSE);
+    }
+
+    while(*p && isSPACE_utf8_safe(p, end))
+        p += UTF8SKIP(p);
+
+    return p;
+}
+
+#define ensure_module_version(module, version)  S_ensure_module_version(aTHX_ module, version)
+static void S_ensure_module_version(pTHX_ SV *module, SV *version)
+{
+    dSP;
+
+    ENTER;
+
+    PUSHMARK(SP);
+    PUSHs(module);
+    PUSHs(version);
+    PUTBACK;
+
+    call_method("VERSION", G_VOID);
+
+    LEAVE;
+}
+
+static void
+apply_class_attribute_isa(pTHX_ HV *stash, SV *value)
+{
+    assert(HvSTASH_IS_CLASS(stash));
+    struct xpvhv_aux *aux = HvAUX(stash);
+
+    /* Parse `value` into name + version */
+    SV *superclassname = sv_newmortal(), *superclassver = sv_newmortal();
+    const char *end = split_package_ver(value, superclassname, superclassver);
+    if(*end)
+        croak("Unexpected characters while parsing class :isa attribute: %s", end);
+
+    if(aux->xhv_class_superclass)
+        croak("Class already has a superclass, cannot add another");
+
+    HV *superstash = gv_stashsv(superclassname, 0);
+    if(!superstash) {
+        /* Try to `require` the module then attempt a second time */
+        load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL);
+        superstash = gv_stashsv(superclassname, 0);
+    }
+    if(!superstash || !HvSTASH_IS_CLASS(superstash))
+        /* TODO: This would be a useful feature addition */
+        croak("Class :isa attribute requires a class but %" HvNAMEf_QUOTEDPREFIX " is not one",
+            HvNAMEfARG(superstash));
+
+    if(superclassver && SvOK(superclassver))
+        ensure_module_version(superclassname, superclassver);
+
+    /* TODO: Suuuurely there's a way to fetch this neatly with stash + "ISA"
+     * You'd think that GvAV() of hv_fetchs() would do it, but no, because it
+     * won't lazily create a proper (magical) GV if one didn't already exist.
+     */
+    AV *isa;
+    {
+        SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash));
+        sv_2mortal(isaname);
+
+        isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8));
+    }
+    av_push(isa, newSVsv(value));
+
+    aux->xhv_class_superclass = (HV *)SvREFCNT_inc(superstash);
+
+    struct xpvhv_aux *superaux = HvAUX(superstash);
+
+    aux->xhv_class_next_fieldix = superaux->xhv_class_next_fieldix;
+
+    if(superaux->xhv_class_adjust_blocks) {
+        if(!aux->xhv_class_adjust_blocks)
+            aux->xhv_class_adjust_blocks = newAV();
+
+        for(U32 i = 0; i <= AvFILL(superaux->xhv_class_adjust_blocks); i++)
+            av_push(aux->xhv_class_adjust_blocks, AvARRAY(superaux->xhv_class_adjust_blocks)[i]);
+    }
+}
+
 static struct {
     const char *name;
     bool requires_value;
     void (*apply)(pTHX_ HV *stash, SV *value);
 } const class_attributes[] = {
+    { .name           = "isa",
+      .requires_value = true,
+      .apply          = &apply_class_attribute_isa,
+    },
     {0}
 };
 
@@ -300,12 +431,26 @@ S_class_apply_attribute(pTHX_ HV *stash, OP *attr)
         if(SvPVX(sv)[svlen-1] != ')')
             /* Should be impossible to reach this by parsing regular perl code
              * by as class_apply_attributes() is XS-visible API it might still
-             * be reachable
+             * be reachable. As it's likely unreachable by normal perl code,
+             * don't bother listing it in perldiag.
              */
             /* diag_listed_as: SKIPME */
             croak("Malformed attribute string");
         name = sv_2mortal(newSVpvn(SvPVX(sv), namelen));
-        value = sv_2mortal(newSVpvn(paren_at + 1, svlen - namelen - 2));
+
+        char *value_at = paren_at + 1;
+        char *value_max = SvPVX(sv) + svlen - 2;
+
+        /* TODO: We're only obeying ASCII whitespace here */
+
+        /* Trim whitespace at the start */
+        while(value_at < value_max && isSPACE(*value_at))
+            value_at += 1;
+        while(value_max > value_at && isSPACE(*value_max))
+            value_max -= 1;
+
+        if(value_max >= value_at)
+            value = sv_2mortal(newSVpvn(value_at, value_max - value_at + 1));
     }
     else {
         name = sv;
@@ -329,6 +474,8 @@ S_class_apply_attribute(pTHX_ HV *stash, OP *attr)
 void
 Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist)
 {
+    PERL_ARGS_ASSERT_CLASS_APPLY_ATTRIBUTES;
+
     if(attrlist->op_type == OP_LIST) {
         OP *o = cLISTOPx(attrlist)->op_first;
         assert(o->op_type == OP_PUSHMARK);

hv.h

@@ -134,6 +134,7 @@ struct xpvhv_aux {
     U32         xhv_aux_flags;      /* assorted extra flags */
 
     /* The following fields are only valid if we have the flag HvAUXf_IS_CLASS */
+    HV          *xhv_class_superclass;         /* STASH of the :isa() base class */
     AV          *xhv_class_adjust_blocks;      /* CVs containing the ADJUST blocks */
     PADNAMELIST *xhv_class_fields;             /* PADNAMEs with PadnameIsFIELD() */
     PADOFFSET    xhv_class_next_fieldix;

pod/perlclass.pod

@@ -57,4 +57,23 @@ list as far as the signature is concerned.
         }
     }
 
+Classes may inherit from B<one> superclass, by using the C<:isa> class
+attribute.
+
+  class Example::Base { ... }
+
+  class Example::Subclass :isa(Example::Base) { ... }
+
+Inherited methods are visible and may be invoked. Fields are always lexical
+and therefore not visible by inheritence.
+
+The C<:isa> attribute may request a minimum version of the base class; it is
+applied similar to C<use>; if the provided version is too low it will fail at
+compile time.
+
+  class Example::Subclass :isa(Example::Base 2.345) { ... }
+
+The C<:isa> attribute will attempt to C<require> the named module if it is not
+already loaded.
+
 =cut

pod/perldiag.pod

@@ -1760,6 +1760,13 @@ is better written as simply itself, perhaps preceded by a backslash
 for non-word characters.  Doing it the way you did is not portable
 between ASCII and EBCDIC platforms.
 
+=item Class already has a superclass, cannot add another
+
+(F) You attempted to specify a second superclass for a C<class> by using
+the C<:isa> attribute, when one is already specified.  Unlike classes
+whose instances are created with C<bless>, classes created via the
+C<class> keyword cannot have more than one superclass.
+
 =item Class attribute %s requires a value
 
 (F) You specified an attribute for a class that would require a value to
@@ -1775,6 +1782,12 @@ you must write this as
 keyword of C<use feature 'class'>.  This keyword is currently
 experimental and its behaviour may change in future releases of Perl.
 
+=item Class :isa attribute requires a class but "%s" is not one
+
+(F) When creating a subclass using the C<class> C<:isa> attribute, the
+named superclass must also be a real class created using the C<class>
+keyword.
+
 =item Cloning substitution context is unimplemented
 
 (F) Creating a new thread inside the C<s///> operator is not supported.
@@ -6817,6 +6830,12 @@ within an inner pair of square brackets, like
 Another possibility is that you forgot a backslash.  Perl isn't smart
 enough to figure out what you really meant.
 
+=item Unexpected characters while parsing class :isa attribute: %s
+
+(F) You tried to specify something other than a single class name with an
+optional trailing verison number as the value for a C<class> C<:isa>
+attribute.  This confused the parser.
+
 =item Unexpected exit %u
 
 (S) exit() was called or the script otherwise finished gracefully when