diff --git a/MANIFEST b/MANIFEST index b63653907a8ac..d4a4052fe68d7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5967,6 +5967,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 07bad10498c04..6ce8d1ae1f332 100644 --- a/class.c +++ b/class.c @@ -805,14 +805,80 @@ Perl_class_seal_stash(pTHX_ HV *stash) aux->xhv_class_initfields_cv = initfields; } else { - /* we had errors, clean up and don't populate initfields */ + /* we had errors, clean up */ + + 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; + } + + /* TODO: cleanup DOES if added above */ + + /* 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(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 = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash)); + sv_2mortal(isaname); + 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; } } diff --git a/t/class/gh22169.t b/t/class/gh22169.t new file mode 100644 index 0000000000000..ce586302a2c59 --- /dev/null +++ b/t/class/gh22169.t @@ -0,0 +1,59 @@ +#!./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; } +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 fde3c7a181c77..a8a7133ca6a5e 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;