Skip to content

Commit

Permalink
class.c: clean up any state if we don't finish the class
Browse files Browse the repository at this point in the history
  • Loading branch information
tonycoz committed Jul 8, 2024
1 parent b786e5e commit 177bd8b
Show file tree
Hide file tree
Showing 4 changed files with 126 additions and 2 deletions.
1 change: 1 addition & 0 deletions MANIFEST
Original file line number Diff line number Diff line change
Expand Up @@ -5970,6 +5970,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
Expand Down
66 changes: 65 additions & 1 deletion class.c
Original file line number Diff line number Diff line change
Expand Up @@ -805,14 +805,78 @@ 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;
}

/* 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;
}
}

Expand Down
59 changes: 59 additions & 0 deletions t/class/gh22169.t
Original file line number Diff line number Diff line change
@@ -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();

2 changes: 1 addition & 1 deletion t/lib/croak/class
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down

0 comments on commit 177bd8b

Please sign in to comment.