#define CVf_WEAKOUTSIDE 0x0010 /* CvOUTSIDE isn't ref counted */
#define CVf_CLONE 0x0020 /* anon CV uses external lexicals */
#define CVf_CLONED 0x0040 /* a clone of one of those */
-#define CVf_ANON 0x0080 /* CvGV() can't be trusted */
+#define CVf_ANON 0x0080 /* implies: CV is not pointed to by a GV,
+ CvGV is refcounted, and
+ points to an __ANON__ GV;
+ at compile time only, also implies sub {} */
#define CVf_UNIQUE 0x0100 /* sub is only called once (eg PL_main_cv,
* require, eval). */
#define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV
Ap |void |gv_fullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool keepmain
: Used in scope.c
pMox |GP * |newGP |NN GV *const gv
+pX |void |cvgv_set |NN CV* cv|NULLOK GV* gv
Ap |void |gv_init |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int multi
Ap |void |gv_name_set |NN GV* gv|NN const char *name|U32 len|U32 flags
XMpd |void |gv_try_downgrade|NN GV* gv
#if defined(PERL_IN_HV_C)
s |void |hsplit |NN HV *hv
s |void |hfreeentries |NN HV *hv
-s |I32 |anonymise_cv |NULLOK HEK *stash|NN SV *val
sa |HE* |new_he
sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool *needs_store
|const int dtype
s |void |glob_assign_ref|NN SV *const dstr|NN SV *const sstr
sRn |PTR_TBL_ENT_t *|ptr_table_find|NN PTR_TBL_t *const tbl|NULLOK const void *const sv
+s |void |anonymise_cv_maybe |NN GV *gv|NN CV *cv
#endif
#if defined(PERL_IN_TOKE_C)
#define gv_fetchpv Perl_gv_fetchpv
#define gv_fullname Perl_gv_fullname
#define gv_fullname4 Perl_gv_fullname4
+#ifdef PERL_CORE
+#define cvgv_set Perl_cvgv_set
+#endif
#define gv_init Perl_gv_init
#define gv_name_set Perl_gv_name_set
#ifdef PERL_CORE
#ifdef PERL_CORE
#define hsplit S_hsplit
#define hfreeentries S_hfreeentries
-#define anonymise_cv S_anonymise_cv
#define new_he S_new_he
#define save_hek_flags S_save_hek_flags
#define hv_magic_check S_hv_magic_check
#define glob_assign_glob S_glob_assign_glob
#define glob_assign_ref S_glob_assign_ref
#define ptr_table_find S_ptr_table_find
+#define anonymise_cv_maybe S_anonymise_cv_maybe
#endif
#endif
#if defined(PERL_IN_TOKE_C)
#define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b)
#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d)
#ifdef PERL_CORE
+#define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b)
#endif
#define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e)
#define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d)
#ifdef PERL_CORE
#define hsplit(a) S_hsplit(aTHX_ a)
#define hfreeentries(a) S_hfreeentries(aTHX_ a)
-#define anonymise_cv(a,b) S_anonymise_cv(aTHX_ a,b)
#define new_he() S_new_he(aTHX)
#define save_hek_flags S_save_hek_flags
#define hv_magic_check S_hv_magic_check
#define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c)
#define glob_assign_ref(a,b) S_glob_assign_ref(aTHX_ a,b)
#define ptr_table_find S_ptr_table_find
+#define anonymise_cv_maybe(a,b) S_anonymise_cv_maybe(aTHX_ a,b)
#endif
#endif
#if defined(PERL_IN_TOKE_C)
Perl_gv_fullname
Perl_gv_fullname3
Perl_gv_fullname4
+Perl_cvgv_set
Perl_gv_init
Perl_gv_name_set
Perl_gv_try_downgrade
return gp;
}
+/* Assign CvGV(cv) = gv, handling weak references.
+ * See also S_anonymise_cv_maybe */
+
+void
+Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+{
+ GV * const oldgv = CvGV(cv);
+ PERL_ARGS_ASSERT_CVGV_SET;
+
+ if (oldgv == gv)
+ return;
+
+ if (oldgv) {
+ if (CvANON(cv))
+ SvREFCNT_dec(oldgv);
+ else {
+ assert(strNE(GvNAME(oldgv),"__ANON__"));
+ sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
+ }
+ }
+
+ CvGV(cv) = gv;
+
+ if (!gv)
+ return;
+
+ if (CvANON(cv)) {
+ assert(strnEQ(GvNAME(gv),"__ANON__", 8));
+ SvREFCNT_inc_simple_void_NN(gv);
+ }
+ else {
+ assert(strNE(GvNAME(gv),"__ANON__"));
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
+ }
+}
+
+
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
LEAVE;
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV(cv) = gv;
+ cvgv_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
if (PL_curstash)
SV **gvp;
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
- !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+ !SvOBJECT(gv) && !SvREADONLY(gv) &&
isGV_with_GP(gv) && GvGP(gv) &&
!GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
+ if (SvMAGICAL(gv)) {
+ MAGIC *mg;
+ /* only backref magic is allowed */
+ if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
+ return;
+ for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type != PERL_MAGIC_backref)
+ return;
+ }
+ }
cv = GvCV(gv);
if (!cv) {
HEK *gvnhek = GvNAME_HEK(gv);
if (!entry)
return;
val = HeVAL(entry);
- if (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val))
- mro_method_changed_in(hv);
+ if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
+ mro_method_changed_in(hv); /* deletion of method from stash */
SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
del_HE(entry);
}
-static I32
-S_anonymise_cv(pTHX_ HEK *stash, SV *val)
-{
- CV *cv;
-
- PERL_ARGS_ASSERT_ANONYMISE_CV;
-
- if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) {
- if ((SV *)CvGV(cv) == val) {
- GV *anongv;
-
- if (stash) {
- SV *gvname = newSVhek(stash);
- sv_catpvs(gvname, "::__ANON__");
- anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
- SvREFCNT_dec(gvname);
- } else {
- anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI,
- SVt_PVCV);
- }
- CvGV(cv) = anongv;
- CvANON_on(cv);
- return 1;
- }
- }
- return 0;
-}
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
if (!orig_array)
return;
- if (HvNAME(hv) && orig_array != NULL) {
- /* symbol table: make all the contained subs ANON */
- STRLEN i;
- XPVHV *xhv = (XPVHV*)SvANY(hv);
-
- for (i = 0; i <= xhv->xhv_max; i++) {
- HE *entry = (HvARRAY(hv))[i];
- for (; entry; entry = HeNEXT(entry)) {
- SV *val = HeVAL(entry);
- /* we need to put the subs in the __ANON__ symtable, as
- * this one is being cleared. */
- anonymise_cv(NULL, val);
- }
- }
- }
-
if (SvOOK(hv)) {
/* If the hash is actually a symbol table with a name, look after the
name. */
LEAVE;
}
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
- CvGV(cv) = NULL;
+ cvgv_set(cv, NULL);
pad_undef(cv);
if (CvISXSUB(cv) && CvXSUB(cv)) {
CvXSUB(cv) = NULL;
}
- /* delete all flags except WEAKOUTSIDE */
- CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
+ /* delete all flags except WEAKOUTSIDE and ANON, which indicate the
+ * ref status of CvOUTSIDE and CvGV */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_ANON);
}
void
}
}
if (!CvGV(cv)) {
- CvGV(cv) = gv;
+ cvgv_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
if (PL_curstash)
mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
- CvGV(cv) = gv;
+ if (!name)
+ CvANON_on(cv);
+ cvgv_set(cv, gv);
(void)gv_fetchfile(filename);
CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
if (name)
process_special_blocks(name, gv, cv);
- else
- CvANON_on(cv);
return cv;
}
}
cv = PL_compcv;
GvFORM(gv) = cv;
- CvGV(cv) = gv;
+ cvgv_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
#else
CvFILE(cv) = CvFILE(proto);
#endif
- CvGV(cv) = CvGV(proto);
+ cvgv_set(cv,CvGV(proto));
CvSTASH(cv) = CvSTASH(proto);
if (CvSTASH(cv))
Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
/* let user-undef'd sub keep its identity */
GV* const gv = CvGV((const CV *)sv);
cv_undef(MUTABLE_CV(sv));
- CvGV((const CV *)sv) = gv;
+ cvgv_set(MUTABLE_CV(sv), gv);
}
break;
case SVt_PVGV:
#define PERL_ARGS_ASSERT_NEWGP \
assert(gv)
+PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CVGV_SET \
+ assert(cv)
+
PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_HFREEENTRIES \
assert(hv)
-STATIC I32 S_anonymise_cv(pTHX_ HEK *stash, SV *val)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_ANONYMISE_CV \
- assert(val)
-
STATIC HE* S_new_he(pTHX)
__attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_PTR_TABLE_FIND \
assert(tbl)
+STATIC void S_anonymise_cv_maybe(pTHX_ GV *gv, CV *cv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE \
+ assert(gv); assert(cv)
+
#endif
#if defined(PERL_IN_TOKE_C)
SV **svp = AvARRAY(av);
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
- PERL_UNUSED_ARG(sv);
if (svp) {
SV *const *const last = svp + AvFILLp(av);
SvSETMAGIC(referrer);
} else if (SvTYPE(referrer) == SVt_PVGV ||
SvTYPE(referrer) == SVt_PVLV) {
+ assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
/* You lookin' at me? */
assert(GvSTASH(referrer));
assert(GvSTASH(referrer) == (const HV *)sv);
GvSTASH(referrer) = 0;
- } else if (SvTYPE(referrer) == SVt_PVCV) {
- /* You lookin' at me? */
- assert(CvSTASH(referrer));
- assert(CvSTASH(referrer) == (const HV *)sv);
- CvSTASH(referrer) = 0;
+ } else if (SvTYPE(referrer) == SVt_PVCV ||
+ SvTYPE(referrer) == SVt_PVFM) {
+ if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+ /* You lookin' at me? */
+ assert(CvSTASH(referrer));
+ assert(CvSTASH(referrer) == (const HV *)sv);
+ CvSTASH(referrer) = 0;
+ }
+ else {
+ assert(SvTYPE(sv) == SVt_PVGV);
+ /* You lookin' at me? */
+ assert(CvGV(referrer));
+ assert(CvGV(referrer) == (const GV *)sv);
+ anonymise_cv_maybe(MUTABLE_GV(sv),
+ MUTABLE_CV(referrer));
+ }
+
} else {
Perl_croak(aTHX_
"panic: magic_killbackrefs (flags=%"UVxf")",
del_SV(nsv);
}
+/* We're about to free a GV which has a CV that refers back to us.
+ * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+ * field) */
+
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+ char *stash;
+ SV *gvname;
+ GV *anongv;
+
+ PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+
+ /* be assertive! */
+ assert(SvREFCNT(gv) == 0);
+ assert(isGV(gv) && isGV_with_GP(gv));
+ assert(GvGP(gv));
+ assert(!CvANON(cv));
+ assert(CvGV(cv) == gv);
+
+ /* will the CV shortly be freed by gp_free() ? */
+ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+ CvGV(cv) = NULL;
+ return;
+ }
+
+ /* if not, anonymise: */
+ stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
+ stash ? stash : "__ANON__");
+ anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+ SvREFCNT_dec(gvname);
+
+ CvANON_on(cv);
+ CvGV(cv) = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+
+
/*
=for apidoc sv_clear
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
+
+ if ((param->flags & CLONEf_JOIN_IN)
+ && mg->mg_type == PERL_MAGIC_backref)
+ /* when joining, we let the individual SVs add themselves to
+ * backref as needed. */
+ continue;
+
Newx(nmg, 1, MAGIC);
*mgprev_p = nmg;
mgprev_p = &(nmg->mg_moremagic);
PERL_ARGS_ASSERT_RVPV_DUP;
if (SvROK(sstr)) {
- SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV_const(sstr), param)
- : sv_dup_inc(SvRV_const(sstr), param));
-
+ if (SvWEAKREF(sstr)) {
+ SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+ if (param->flags & CLONEf_JOIN_IN) {
+ /* if joining, we add any back references individually rather
+ * than copying the whole backref array */
+ Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+ }
+ }
+ else
+ SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
}
else if (SvPVX_const(sstr)) {
/* Has something there */
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- NULL : gv_dup(CvGV(dstr), param) ;
+ CvGV(dstr) =
+ CvANON(dstr)
+ ? gv_dup_inc(CvGV(sstr), param)
+ : (param->flags & CLONEf_JOIN_IN)
+ ? NULL
+ : gv_dup(CvGV(sstr), param);
+
CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
-is( $c[3], "(unknown)", "unknown subroutine name" );
-ok( $c[4], "hasargs true with unknown sub" );
+is( $c[3], "main::__ANON__", "deleted subroutine name" );
+ok( $c[4], "hasargs true with deleted sub" );
print "# Tests with caller(1)\n";
sub foo2 { f() }
my $fooref2 = delete $::{foo2};
$fooref2 -> ();
-is( $c[3], "(unknown)", "unknown subroutine name" );
-ok( $c[4], "hasargs true with unknown sub" );
+is( $c[3], "main::__ANON__", "deleted subroutine name" );
+ok( $c[4], "hasargs true with deleted sub" );
# See if caller() returns the correct warning mask
BEGIN { require "./test.pl"; }
-plan( tests => 32 );
+plan( tests => 37 );
# Used to segfault (bug #15479)
fresh_perl_like(
is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
- TODO: {
- local $TODO = "anon CVs not accounted for yet";
-
- my @results = split "\n", runperl(
- switches => [ "-MB", "-l" ],
- prog => q{
- my $sub = do {
- package four;
- sub { 1 };
- };
- %four:: = ();
-
- my $gv = B::svref_2object($sub)->GV;
- print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
-
- my $st = eval { $gv->STASH->NAME };
- print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
-
- my $sub = do {
- package five;
- sub { 1 };
- };
- undef %five::;
-
- $gv = B::svref_2object($sub)->GV;
- print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
-
- $st = eval { $gv->STASH->NAME };
- print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
-
- print q/done/;
- },
- ($^O eq 'VMS') ? (stderr => 1) : ()
- );
-
- ok( @results == 5 && $results[4] eq "done",
- "anon CVs in undefed stash don't segfault" )
- or todo_skip $TODO, 4;
-
- ok( $results[0] eq "ok",
- "cleared stash leaves anon CV with valid GV");
- ok( $results[1] eq "ok",
- "...and an __ANON__ stash");
-
- ok( $results[2] eq "ok",
- "undefed stash leaves anon CV with valid GV");
- ok( $results[3] eq "ok",
- "...and an __ANON__ stash");
+ my $sub = do {
+ package four;
+ sub { 1 };
+ };
+ %four:: = ();
+
+ my $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
+
+ my $st = eval { $gv->STASH->NAME };
+ { local $TODO = 'STASHES not anonymized';
+ is($st, q/__ANON__/, "...and an __ANON__ stash");
+ }
+
+ my $sub = do {
+ package five;
+ sub { 1 };
+ };
+ undef %five::;
+
+ $gv = B::svref_2object($sub)->GV;
+ ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
+
+ $st = eval { $gv->STASH->NAME };
+ { local $TODO = 'STASHES not anonymized';
+ is($st, q/__ANON__/, "...and an __ANON__ stash");
}
-
+
# [perl #58530]
fresh_perl_is(
'sub foo { 1 }; use overload q/""/ => \&foo;' .
"no segfault with overload/deleted stash entry [#58530]",
);
- # CvSTASH should be null on a nmed sub if the stash has been deleted
+ # CvSTASH should be null on a named sub if the stash has been deleted
{
package FOO;
sub foo {}
package main;
delete $::{'FOO::'};
my $cv = B::svref_2object($rfoo);
- # XXX is there a better way of testing for NULL ?
+ # (is there a better way of testing for NULL ?)
my $stash = $cv->STASH;
like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
}
+
+ # on glob reassignment, orphaned CV should have anon CvGV
+
+ {
+ my $r;
+ eval q[
+ package FOO2;
+ sub f{};
+ $r = \&f;
+ *f = sub {};
+ ];
+ delete $FOO2::{f};
+ my $cv = B::svref_2object($r);
+ my $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
+ is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
+ }
+
+ # deleting __ANON__ glob shouldn't break things
+
+ {
+ package FOO3;
+ sub named {};
+ my $anon = sub {};
+ my $named = eval q[\&named];
+ package main;
+ delete $FOO3::{named}; # make named anonymous
+
+ delete $FOO3::{__ANON__}; # whoops!
+ my ($cv,$gv);
+ $cv = B::svref_2object($named);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
+ is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
+
+ $cv = B::svref_2object($anon);
+ $gv = $cv->GV;
+ ok($gv->isa(q/B::GV/), "anon CV has valid GV");
+ is($gv->NAME, '__ANON__', "anon CV has anon GV");
+ }
}
projects / platform / upstream / perl.git / commitdiff