From 32bd2da86d3083651b4b1ab4b80c2983c6685d6c Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 12 Jun 2024 14:33:34 +1000 Subject: [PATCH] class.c: clean up any state if we don't finish the class Fixes #22169 --- MANIFEST | 1 + class.c | 376 ++++++++++++++++++++++++++++------------------ embed.fnc | 4 + embed.h | 3 + proto.h | 7 + t/class/gh22169.t | 60 ++++++++ t/lib/croak/class | 2 +- 7 files changed, 304 insertions(+), 149 deletions(-) create mode 100644 t/class/gh22169.t diff --git a/MANIFEST b/MANIFEST index b44bc5f66452..09758dd36aeb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6008,6 +6008,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/gh22169.t Test defining a class that previously failed to define 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 diff --git a/class.c b/class.c index 0c4889d875c6..d6d801928d0b 100644 --- a/class.c +++ b/class.c @@ -644,184 +644,264 @@ Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist) op_free(attrlist); } +/* + +Called when a compilation failure occurs when defining a class. + +Returns the given stash to a clean state, as if none of the class has +been defined so a new attempt can be made. + +*/ + +static void +S_class_cleanup_definition(pTHX_ HV *stash) { + struct xpvhv_aux *aux = HvAUX(stash); + + SvREFCNT_dec(aux->xhv_class_superclass); + aux->xhv_class_superclass = NULL; + + /* clean up adjust blocks */ + SvREFCNT_dec(aux->xhv_class_adjust_blocks); + aux->xhv_class_adjust_blocks = NULL; + + /* name to slot index */ + SvREFCNT_dec(aux->xhv_class_param_map); + aux->xhv_class_param_map = NULL; + + /* clean up the ops for defaults for fields, if any, since + padname_free() doesn't. + */ + PADNAMELIST *fieldnames = aux->xhv_class_fields; + if (fieldnames) { + for(SSize_t i = PadnamelistMAX(fieldnames); i >= 0 ; i--) { + PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; + op_free(PadnameFIELDINFO(pn)->defop); + PadnameFIELDINFO(pn)->defop = NULL; + } + PadnamelistREFCNT_dec(fieldnames); + aux->xhv_class_fields = NULL; + } + + /* clean up methods */ + /* should we keep a separate list of these instead? */ + if (hv_iterinit(stash)) { + HE *he; + while ((he = hv_iternext(stash)) != NULL) { + STRLEN klen; + const char * const kpv = HePV(he, klen); + SV *entry = HeVAL(he); + CV *cv = NULL; + if (SvTYPE(entry) == SVt_PVGV + && (cv = GvCV((GV*)entry)) + && (CvIsMETHOD(cv) || memEQs(kpv, klen, "new"))) { + SvREFCNT_dec_NN(cv); + GvCV_set((GV*)entry, NULL); + } + else if (SvTYPE(entry) == SVt_PVCV + && (CvIsMETHOD((CV*)entry) || memEQs(kpv, klen, "new"))) { + (void)hv_delete(stash, kpv, HeUTF8(he) ? -(I32)klen : (I32)klen, + G_DISCARD); + } + } + ++PL_sub_generation; + } + + /* field clean up */ + resume_compcv_final(aux->xhv_class_suspended_initfields_compcv); + SvREFCNT_dec(PL_compcv); + Safefree(aux->xhv_class_suspended_initfields_compcv); + aux->xhv_class_suspended_initfields_compcv = NULL; + + /* remove any ISA entries */ + SV *isaname = sv_2mortal(newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash))); + + AV *isa = get_av(SvPV_nolen(isaname), (SvFLAGS(isaname) & SVf_UTF8)); + if (isa) { + /* we make this read-only above since class-keyword + classes manage ISA themselves, the class has failed to + load, so we no longer manage it. + */ + SvREADONLY_off((SV *)isa); + av_clear(isa); + } + + /* no longer a class */ + aux->xhv_aux_flags &= ~HvAUXf_IS_CLASS; +} + void Perl_class_seal_stash(pTHX_ HV *stash) { PERL_ARGS_ASSERT_CLASS_SEAL_STASH; assert(HvSTASH_IS_CLASS(stash)); - struct xpvhv_aux *aux = HvAUX(stash); - if (PL_parser->error_count == 0) { - /* generate initfields CV */ - I32 floor_ix = PL_savestack_ix; - SAVEI32(PL_subline); - save_item(PL_subname); + if (PL_parser->error_count) { + /* we had errors, clean up */ + class_cleanup_definition(stash); + return; + } - resume_compcv_final(aux->xhv_class_suspended_initfields_compcv); + struct xpvhv_aux *aux = HvAUX(stash); - /* Some OP_INITFIELD ops will need to populate the pad with their - * result because later ops will rely on it. There's no need to do - * this for every op though. Store a mapping to work out which ones - * we'll need. - */ - PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); - HV *fieldix_to_padix = newHV(); - SAVEFREESV((SV *)fieldix_to_padix); - - /* padix 0 == @_; padix 1 == $self. Start at 2 */ - for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { - PADNAME *pn = PadnamelistARRAY(pnl)[padix]; - if(!pn || !PadnameIsFIELD(pn)) - continue; - - U32 fieldix = PadnameFIELDINFO(pn)->fieldix; - (void)hv_store_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), newSVuv(padix), 0); - } + /* generate initfields CV */ + I32 floor_ix = PL_savestack_ix; + SAVEI32(PL_subline); + save_item(PL_subname); - OP *ops = NULL; + resume_compcv_final(aux->xhv_class_suspended_initfields_compcv); - ops = op_append_list(OP_LINESEQ, ops, - newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL)); + /* Some OP_INITFIELD ops will need to populate the pad with their + * result because later ops will rely on it. There's no need to do + * this for every op though. Store a mapping to work out which ones + * we'll need. + */ + PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); + HV *fieldix_to_padix = newHV(); + SAVEFREESV((SV *)fieldix_to_padix); - if(aux->xhv_class_superclass) { - HV *superstash = aux->xhv_class_superclass; - assert(HvSTASH_IS_CLASS(superstash)); - struct xpvhv_aux *superaux = HvAUX(superstash); + /* padix 0 == @_; padix 1 == $self. Start at 2 */ + for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { + PADNAME *pn = PadnamelistARRAY(pnl)[padix]; + if(!pn || !PadnameIsFIELD(pn)) + continue; - /* Build an OP_ENTERSUB */ - OP *o = newLISTOPn(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, - newPADxVOP(OP_PADSV, 0, PADIX_SELF), - newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), - /* TODO: This won't work at all well under `use threads` because - * it embeds the CV * to the superclass initfields CV right into - * the optree. Maybe we'll have to pop it in the pad or something - */ - newSVOP(OP_CONST, 0, (SV *)superaux->xhv_class_initfields_cv), - NULL); + U32 fieldix = PadnameFIELDINFO(pn)->fieldix; + (void)hv_store_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), newSVuv(padix), 0); + } - ops = op_append_list(OP_LINESEQ, ops, o); - } + OP *ops = NULL; - PADNAMELIST *fieldnames = aux->xhv_class_fields; + ops = op_append_list(OP_LINESEQ, ops, + newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL)); - for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { - PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; - char sigil = PadnamePV(pn)[0]; - PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; + if(aux->xhv_class_superclass) { + HV *superstash = aux->xhv_class_superclass; + assert(HvSTASH_IS_CLASS(superstash)); + struct xpvhv_aux *superaux = HvAUX(superstash); - /* Extract the OP_{NEXT,DB}STATE op from the defop so we can - * splice it in + /* Build an OP_ENTERSUB */ + OP *o = newLISTOPn(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, + newPADxVOP(OP_PADSV, 0, PADIX_SELF), + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), + /* TODO: This won't work at all well under `use threads` because + * it embeds the CV * to the superclass initfields CV right into + * the optree. Maybe we'll have to pop it in the pad or something */ - OP *valop = PadnameFIELDINFO(pn)->defop; - if(valop && valop->op_type == OP_LINESEQ) { - OP *o = cLISTOPx(valop)->op_first; - cLISTOPx(valop)->op_first = NULL; - cLISTOPx(valop)->op_last = NULL; - /* have to clear the OPf_KIDS flag or op_free() will get upset */ - valop->op_flags &= ~OPf_KIDS; - op_free(valop); - - OP *fieldcop = o; - assert(fieldcop->op_type == OP_NEXTSTATE || fieldcop->op_type == OP_DBSTATE); - o = OpSIBLING(o); - OpLASTSIB_set(fieldcop, NULL); - - valop = o; - OpLASTSIB_set(valop, NULL); - - ops = op_append_list(OP_LINESEQ, ops, fieldcop); - } + newSVOP(OP_CONST, 0, (SV *)superaux->xhv_class_initfields_cv), + NULL); - SV *paramname = PadnameFIELDINFO(pn)->paramname; - - U8 op_priv = 0; - switch(sigil) { - case '$': - if(paramname) { - if(!valop) { - SV *message = - newSVpvf("Required parameter '%" SVf "' is missing for %" HvNAMEf_QUOTEDPREFIX " constructor", - SVfARG(paramname), HvNAMEfARG(stash)); - valop = newLISTOPn(OP_DIE, 0, - newSVOP(OP_CONST, 0, message), - NULL); - } - - OP *helemop = - newBINOP(OP_HELEM, 0, - newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), - newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); - - if(PadnameFIELDINFO(pn)->def_if_undef) { - /* delete $params{$paramname} // DEFOP */ - valop = newLOGOP(OP_DOR, 0, - newUNOP(OP_DELETE, 0, helemop), valop); - } - else if(PadnameFIELDINFO(pn)->def_if_false) { - /* delete $params{$paramname} || DEFOP */ - valop = newLOGOP(OP_OR, 0, - newUNOP(OP_DELETE, 0, helemop), valop); - } - else { - /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */ - /* more efficient with the new OP_HELEMEXISTSOR */ - valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8, - helemop, valop); - } - - valop = op_contextualize(valop, G_SCALAR); - } - break; - - case '@': - op_priv = OPpINITFIELD_AV; - break; - - case '%': - op_priv = OPpINITFIELD_HV; - break; - - default: - NOT_REACHED; - } + ops = op_append_list(OP_LINESEQ, ops, o); + } - UNOP_AUX_item *aux; - aux = (UNOP_AUX_item *)PerlMemShared_malloc( - sizeof(UNOP_AUX_item) * 2); + PADNAMELIST *fieldnames = aux->xhv_class_fields; - aux[0].uv = fieldix; + for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { + PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; + char sigil = PadnamePV(pn)[0]; + PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; - OP *fieldop = newUNOP_AUX(OP_INITFIELD, valop ? OPf_STACKED : 0, valop, aux); - fieldop->op_private = op_priv; + /* Extract the OP_{NEXT,DB}STATE op from the defop so we can + * splice it in + */ + OP *valop = PadnameFIELDINFO(pn)->defop; + if(valop && valop->op_type == OP_LINESEQ) { + OP *o = cLISTOPx(valop)->op_first; + cLISTOPx(valop)->op_first = NULL; + cLISTOPx(valop)->op_last = NULL; + /* have to clear the OPf_KIDS flag or op_free() will get upset */ + valop->op_flags &= ~OPf_KIDS; + op_free(valop); + + OP *fieldcop = o; + assert(fieldcop->op_type == OP_NEXTSTATE || fieldcop->op_type == OP_DBSTATE); + o = OpSIBLING(o); + OpLASTSIB_set(fieldcop, NULL); + + valop = o; + OpLASTSIB_set(valop, NULL); + + ops = op_append_list(OP_LINESEQ, ops, fieldcop); + } + + SV *paramname = PadnameFIELDINFO(pn)->paramname; - HE *he; - if((he = hv_fetch_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), 0, 0)) && - SvOK(HeVAL(he))) { - fieldop->op_targ = SvUV(HeVAL(he)); + U8 op_priv = 0; + switch(sigil) { + case '$': + if(paramname) { + if(!valop) { + SV *message = + newSVpvf("Required parameter '%" SVf "' is missing for " + "%" HvNAMEf_QUOTEDPREFIX " constructor", + SVfARG(paramname), HvNAMEfARG(stash)); + valop = newLISTOPn(OP_DIE, 0, + newSVOP(OP_CONST, 0, message), + NULL); + } + + OP *helemop = + newBINOP(OP_HELEM, 0, + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), + newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); + + if(PadnameFIELDINFO(pn)->def_if_undef) { + /* delete $params{$paramname} // DEFOP */ + valop = newLOGOP(OP_DOR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else if(PadnameFIELDINFO(pn)->def_if_false) { + /* delete $params{$paramname} || DEFOP */ + valop = newLOGOP(OP_OR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else { + /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */ + /* more efficient with the new OP_HELEMEXISTSOR */ + valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8, + helemop, valop); + } + + valop = op_contextualize(valop, G_SCALAR); } + break; + + case '@': + op_priv = OPpINITFIELD_AV; + break; + + case '%': + op_priv = OPpINITFIELD_HV; + break; - ops = op_append_list(OP_LINESEQ, ops, fieldop); + default: + NOT_REACHED; } - /* initfields CV should not get class_wrap_method_body() called on its - * body. pretend it isn't a method for now */ - CvIsMETHOD_off(PL_compcv); - CV *initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); - CvIsMETHOD_on(initfields); + UNOP_AUX_item *aux; + aux = (UNOP_AUX_item *)PerlMemShared_malloc(sizeof(UNOP_AUX_item) * 2); - aux->xhv_class_initfields_cv = initfields; - } - else { - /* we had errors, clean up and don't populate initfields */ - PADNAMELIST *fieldnames = aux->xhv_class_fields; - if (fieldnames) { - for(SSize_t i = PadnamelistMAX(fieldnames); i >= 0 ; i--) { - PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; - op_free(PadnameFIELDINFO(pn)->defop); - } + aux[0].uv = fieldix; + + OP *fieldop = newUNOP_AUX(OP_INITFIELD, valop ? OPf_STACKED : 0, valop, aux); + fieldop->op_private = op_priv; + + HE *he; + if((he = hv_fetch_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), 0, 0)) && + SvOK(HeVAL(he))) { + fieldop->op_targ = SvUV(HeVAL(he)); } + + ops = op_append_list(OP_LINESEQ, ops, fieldop); } + + /* initfields CV should not get class_wrap_method_body() called on its + * body. pretend it isn't a method for now */ + CvIsMETHOD_off(PL_compcv); + CV *initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); + CvIsMETHOD_on(initfields); + + aux->xhv_class_initfields_cv = initfields; } void diff --git a/embed.fnc b/embed.fnc index 762f47f06c63..5ddab55acec8 100644 --- a/embed.fnc +++ b/embed.fnc @@ -4226,6 +4226,10 @@ p |void |prepare_export_lexical p |void |XS_builtin_indexed \ |NN CV *cv #endif +#if defined(PERL_IN_CLASS_C) +S |void |class_cleanup_definition \ + |NN HV *stash +#endif #if defined(PERL_IN_CLASS_C) || defined(PERL_IN_OP_C) || \ defined(PERL_IN_PAD_C) || defined(PERL_IN_PERLY_C) || \ defined(PERL_IN_TOKE_C) diff --git a/embed.h b/embed.h index 6cb789ce5e02..9c5c2a8acf04 100644 --- a/embed.h +++ b/embed.h @@ -1248,6 +1248,9 @@ # define import_builtin_bundle(a) Perl_import_builtin_bundle(aTHX_ a) # define prepare_export_lexical() Perl_prepare_export_lexical(aTHX) # endif +# if defined(PERL_IN_CLASS_C) +# define class_cleanup_definition(a) S_class_cleanup_definition(aTHX_ a) +# endif # if defined(PERL_IN_CLASS_C) || defined(PERL_IN_GLOBALS_C) || \ defined(PERL_IN_OP_C) || defined(PERL_IN_PEEP_C) # define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) diff --git a/proto.h b/proto.h index d648766b4898..a7e81e069149 100644 --- a/proto.h +++ b/proto.h @@ -6325,6 +6325,13 @@ Perl_prepare_export_lexical(pTHX) # define PERL_ARGS_ASSERT_PREPARE_EXPORT_LEXICAL #endif /* defined(PERL_IN_BUILTIN_C) || defined(PERL_IN_OP_C) */ +#if defined(PERL_IN_CLASS_C) +STATIC void +S_class_cleanup_definition(pTHX_ HV *stash); +# define PERL_ARGS_ASSERT_CLASS_CLEANUP_DEFINITION \ + assert(stash); assert(SvTYPE(stash) == SVt_PVHV) + +#endif #if defined(PERL_IN_CLASS_C) || defined(PERL_IN_GLOBALS_C) || \ defined(PERL_IN_OP_C) || defined(PERL_IN_PEEP_C) PERL_CALLCONV OP * diff --git a/t/class/gh22169.t b/t/class/gh22169.t new file mode 100644 index 000000000000..f85ee179729b --- /dev/null +++ b/t/class/gh22169.t @@ -0,0 +1,60 @@ +#!./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 Base { + method g() { "Base" } + ADJUST { + ::fail("original Base ADJUST block should not be called"); + } +} + +class Base2 { + method g() { "Base2" } +} + +BEGIN { + our $saw_end; + eval <<'CLASS'; +class MyTest :isa(Base) { + field $x = "First"; + field $w :reader; + ADJUST { + ::fail("ADJUST from failed class definition called"); + } + method f () { $x } + method h() { } + method z() { } + # make sure some error above doesn't invalidate the test, this + BEGIN { ++$saw_end; } +# no } +CLASS + ok($saw_end, "saw the end of the incomplete class definition"); +} + +class MyTest :isa(Base2) { + field $y = "Second"; + method f() { $y } + ADJUST { + ::pass("saw adjust in replacement class definition"); + } +} + +my $z = new_ok("MyTest"); +ok(!$z->can("h"), "h() should no longer be present"); +isa_ok($z, "Base2", "check base class"); +is($z->g(), "Base2", "Base class correct via g"); +is($z->f(), "Second", "f() value"); +ok(!$z->can("w"), 'accessor for $w removed'); + +done_testing(); + diff --git a/t/lib/croak/class b/t/lib/croak/class index 9f5db208e812..a250572c18ef 100644 --- a/t/lib/croak/class +++ b/t/lib/croak/class @@ -145,7 +145,7 @@ no warnings 'experimental::class'; eval "class C {"; C->new; EXPECT -Cannot create an object of incomplete class "C" at - line 5. +Can't locate object method "new" via package "C" at - line 5. ######## # NAME try to create an object of incomplete class (compile-time) use v5.36;