diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | class.c | 221 | ||||
| -rw-r--r-- | hv.h | 1 | ||||
| -rw-r--r-- | pod/perlclass.pod | 19 | ||||
| -rw-r--r-- | pod/perldiag.pod | 19 | ||||
| -rw-r--r-- | t/class/inherit.t | 53 |
6 files changed, 277 insertions, 37 deletions
@@ -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 @@ -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); @@ -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; diff --git a/pod/perlclass.pod b/pod/perlclass.pod index c0606dc442..412237de37 100644 --- a/pod/perlclass.pod +++ b/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 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 91455c9cd1..c0ca5cc007 100644 --- a/pod/perldiag.pod +++ b/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 diff --git a/t/class/inherit.t b/t/class/inherit.t new file mode 100644 index 0000000000..d9972f5161 --- /dev/null +++ b/t/class/inherit.t @@ -0,0 +1,53 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); + require Config; +} + +use v5.36; +use feature 'class'; +no warnings 'experimental::class'; + +{ + class Test1A { + field $x; + ADJUST { $x = "base class" } + method x { return $x; } + } + + class Test1B :isa(Test1A) { + field $y; + ADJUST { $y = "derived class" } + method y { return $y; } + } + + my $obj = Test1B->new; + ok($obj isa Test1B, 'Object is its own class'); + ok($obj isa Test1A, 'Object is also its base class'); + + is($obj->y, "derived class", 'Object has derived class field'); + + can_ok($obj, "x"); + is($obj->x, "base class", 'Object has base class field'); + + class Test1C :isa( Test1A ) { } + + my $objc = Test1C->new; + ok($objc isa Test1A, ':isa attribute trims whitespace'); +} + +{ + class Test2A 1.23 { } + + class Test2B :isa(Test2A 1.0) { } # OK + + ok(!defined eval "class Test2C :isa(Test2A 2.0) {}; 1", + ':isa() version test can throw'); + like($@, qr/^Test2A version 2\.0 required--this is only version 1\.23 at /, + 'Exception thrown from :isa version test'); +} + +done_testing; |