diff options
| -rw-r--r-- | cv.h | 11 | ||||
| -rw-r--r-- | dump.c | 1 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 42 | ||||
| -rw-r--r-- | op.c | 46 | ||||
| -rw-r--r-- | pad.c | 13 | ||||
| -rw-r--r-- | pod/perldelta.pod | 7 | ||||
| -rw-r--r-- | sv.c | 2 | ||||
| -rw-r--r-- | universal.c | 9 |
8 files changed, 59 insertions, 72 deletions
@@ -51,9 +51,11 @@ For more information, see L<perlguts>. #define CvGV_set(cv,gv) Perl_cvgv_set(aTHX_ cv, gv) #define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file #ifdef USE_ITHREADS -# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = savepv(CopFILE(cop))) +# define CvFILE_set_from_cop(sv, cop) \ + (CvFILE(sv) = savepv(CopFILE(cop)), CvDYNFILE_on(sv)) #else -# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = CopFILE(cop)) +# define CvFILE_set_from_cop(sv, cop) \ + (CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv)) #endif #define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv))) #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) @@ -83,6 +85,7 @@ For more information, see L<perlguts>. #define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV (esp. useful for special XSUBs) */ #define CVf_CVGV_RC 0x0400 /* CvGV is reference counted */ +#define CVf_DYNFILE 0x1000 /* The filename isn't static */ /* This symbol for optimised communication between toke.c and op.c: */ #define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE) @@ -140,6 +143,10 @@ For more information, see L<perlguts>. #define CvCVGV_RC_on(cv) (CvFLAGS(cv) |= CVf_CVGV_RC) #define CvCVGV_RC_off(cv) (CvFLAGS(cv) &= ~CVf_CVGV_RC) +#define CvDYNFILE(cv) (CvFLAGS(cv) & CVf_DYNFILE) +#define CvDYNFILE_on(cv) (CvFLAGS(cv) |= CVf_DYNFILE) +#define CvDYNFILE_off(cv) (CvFLAGS(cv) &= ~CVf_DYNFILE) + /* Flags for newXS_flags */ #define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */ @@ -1446,6 +1446,7 @@ const struct flag_to_name cv_flags_names[] = { {CVf_METHOD, "METHOD,"}, {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}, {CVf_CVGV_RC, "CVGV_RC,"}, + {CVf_DYNFILE, "DYNFILE,"}, {CVf_ISXSUB, "ISXSUB,"} }; diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index d582a8f03c..f9074f0e96 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -25,6 +25,8 @@ Good @>>>>> $::mmmm . +use constant thr => $Config{useithreads}; + sub do_test { my $todo = $_[3]; my $repeat_todo = $_[4]; @@ -54,11 +56,10 @@ sub do_test { # legitimate regexp, it still isn't true. Seems easier and clearer # things that look like comments. - my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/; # Could do this is in a s///mge but seems clearer like this: $pattern = join '', map { # If we identify the version condition, take *it* out whatever - s/\s*# ($version_condition(?: && $version_condition)?)$// + s/\s*# (\$].*)$// ? (eval $1 ? $_ : '') : $_ # Didn't match, so this line is in } split /^/, $pattern; @@ -264,7 +265,8 @@ do_test('reference to anon sub with empty prototype', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) + FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr + FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 PROTOTYPE = "" @@ -279,7 +281,8 @@ do_test('reference to anon sub with empty prototype', MUTEXP = $ADDR OWNER = $ADDR)? FLAGS = 0x404 # $] < 5.009 - FLAGS = 0x490 # $] >= 5.009 + FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr) + FLAGS = 0x1490 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) @@ -293,7 +296,8 @@ do_test('reference to named subroutine without prototype', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = (3|4) - FLAGS = \\(\\) + FLAGS = \\(\\) # $] < 5.015 || !thr + FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 COMP_STASH = $ADDR\\t"main" @@ -303,17 +307,17 @@ do_test('reference to named subroutine without prototype', XSUBANY = 0 # $] < 5.009 GVGV::GV = $ADDR\\t"main" :: "do_test" FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 1 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x0 + DEPTH = 1(?: + MUTEXP = $ADDR + OWNER = $ADDR)? + FLAGS = 0x0 # $] < 5.015 || !thr + FLAGS = 0x1000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo" \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo" \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" - \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition" \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump" @@ -601,7 +605,8 @@ do_test('constant subroutine', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = (2) - FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) + FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015 + FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015 IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 PROTOTYPE = "" @@ -622,7 +627,8 @@ do_test('constant subroutine', OWNER = $ADDR)? FLAGS = 0x200 # $] < 5.009 FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013 - FLAGS = 0xc # $] >= 5.013 + FLAGS = 0xc # $] >= 5.013 && $] < 5.015 + FLAGS = 0x100c # $] >= 5.015 OUTSIDE_SEQ = 0 PADLIST = 0x0 OUTSIDE = 0x0 \\(null\\)'); @@ -670,7 +676,8 @@ do_test('FORMAT', RV = $ADDR SV = PVFM\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(\\) + FLAGS = \\(\\) # $] < 5.015 || !thr + FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 (?: PV = 0 @@ -680,11 +687,12 @@ do_test('FORMAT', XSUB = 0x0 # $] < 5.009 XSUBANY = 0 # $] < 5.009 GVGV::GV = $ADDR\\t"main" :: "PIE" - FILE = ".*\\b(?i:peek\\.t)" -(?: DEPTH = 0 + FILE = ".*\\b(?i:peek\\.t)"(?: + DEPTH = 0 MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x0 + OWNER = $ADDR)? + FLAGS = 0x0 # $] < 5.015 || !thr + FLAGS = 0x1000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ LINES = 0 PADLIST = $ADDR @@ -6258,8 +6258,6 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, { PERL_ARGS_ASSERT_CV_CKPROTO_LEN; - /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by - relying on SvCUR, and doubling up the buffer to hold CvFILE(). */ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ || (p && (len != SvCUR(cv) /* Not the same length. */ || memNE(p, SvPVX_const(cv), len)))) @@ -6619,12 +6617,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvOUTSIDE(PL_compcv) = temp_cv; CvPADLIST(PL_compcv) = temp_av; -#ifdef USE_ITHREADS - if (CvFILE(cv) && !CvISXSUB(cv)) { - /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + if (CvFILE(cv) && CvDYNFILE(cv)) { Safefree(CvFILE(cv)); } -#endif CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); @@ -6883,7 +6878,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) CopSTASH_set(PL_curcop,stash); } - /* file becomes the CvFILE. For an XS, it's supposed to be static storage, + /* file becomes the CvFILE. For an XS, it's usually static storage, and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ @@ -6911,40 +6906,10 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, PERL_ARGS_ASSERT_NEWXS_FLAGS; if (flags & XS_DYNAMIC_FILENAME) { - /* We need to "make arrangements" (ie cheat) to ensure that the - filename lasts as long as the PVCV we just created, but also doesn't - leak */ - STRLEN filename_len = strlen(filename); - STRLEN proto_and_file_len = filename_len; - char *proto_and_file; - STRLEN proto_len; - - if (proto) { - proto_len = strlen(proto); - proto_and_file_len += proto_len; - - Newx(proto_and_file, proto_and_file_len + 1, char); - Copy(proto, proto_and_file, proto_len, char); - Copy(filename, proto_and_file + proto_len, filename_len + 1, char); - } else { - proto_len = 0; - proto_and_file = savepvn(filename, filename_len); - } - - /* This gets free()d. :-) */ - sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len, - SV_HAS_TRAILING_NUL); - if (proto) { - /* This gives us the correct prototype, rather than one with the - file name appended. */ - SvCUR_set(cv, proto_len); - } else { - SvPOK_off(cv); - } - CvFILE(cv) = proto_and_file + proto_len; - } else { - sv_setpv(MUTABLE_SV(cv), proto); + CvFILE(cv) = savepv(filename); + CvDYNFILE_on(cv); } + sv_setpv(MUTABLE_SV(cv), proto); return cv; } @@ -7020,6 +6985,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) (void)gv_fetchfile(filename); CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be an external constant string */ + assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ CvISXSUB_on(cv); CvXSUB(cv) = subaddr; @@ -341,13 +341,10 @@ Perl_cv_undef(pTHX_ CV *cv) PTR2UV(cv), PTR2UV(PL_comppad)) ); -#ifdef USE_ITHREADS - if (CvFILE(cv) && !CvISXSUB(cv)) { - /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + if (CvFILE(cv) && CvDYNFILE(cv)) { Safefree(CvFILE(cv)); } CvFILE(cv) = NULL; -#endif if (!CvISXSUB(cv) && CvROOT(cv)) { if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) @@ -1875,12 +1872,8 @@ Perl_cv_clone(pTHX_ CV *proto) CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC); CvCLONED_on(cv); -#ifdef USE_ITHREADS - CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) - : savepv(CvFILE(proto)); -#else - CvFILE(cv) = CvFILE(proto); -#endif + CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto)) + : CvFILE(proto); CvGV_set(cv,CvGV(proto)); CvSTASH_set(cv, CvSTASH(proto)); OP_REFCNT_LOCK; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e4e45dc346..0c9488a9aa 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -585,6 +585,13 @@ comma operator, which gives all but the last item void context. There is no such thing as void lvalue context, so it was a mistake for Perl to try to force it [perl #96942]. +=item * + +Every subroutine has a filename associated with it, that the debugger uses. +The one associated with constant subroutines used to be misallocated when +cloned under threads. Consequently, debugging threaded applications could +result in memory corruption [perl #96126]. + =back =head1 Known Problems @@ -12016,11 +12016,11 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) OP_REFCNT_LOCK; CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); OP_REFCNT_UNLOCK; - CvFILE(dstr) = SAVEPV(CvFILE(dstr)); } else if (CvCONST(dstr)) { CvXSUBANY(dstr).any_ptr = sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } + if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ SvANY(MUTABLE_CV(dstr))->xcv_gv = diff --git a/universal.c b/universal.c index c891b54bcf..76702ffb39 100644 --- a/universal.c +++ b/universal.c @@ -1293,8 +1293,13 @@ Perl_boot_core_UNIVERSAL(pTHX) PL_amagic_generation++; /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ - CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL)) - = (char *)file; + { + CV * const cv = + newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); + Safefree(CvFILE(cv)); + CvFILE(cv) = (char *)file; + CvDYNFILE_off(cv); + } } /* |