In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c782dc1db597b30ceb55455cfa926e7c4b620944?hp=cae5dbbe30ba4a96ff5e570be0d90779f06fee71>
- Log ----------------------------------------------------------------- commit c782dc1db597b30ceb55455cfa926e7c4b620944 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 13:13:12 2012 -0700 Donât crash when undefining handle of active format format FOO = @ undef *STDOUT . $~ = FOO; write Commit 7ef822cddfe9 began the work by putting in a null check and a goto (to bypass the top format), but the goto wentto some code that lacked the null check. (It did actually fix the case of a IO with no ofp, but not the case of a GV with no IO.) Interestingly, it added a bad_ofp label, but did not add the code to goto it (an oversight?). The unused bad_ofp label was commented out in commit 9cbac4c72b52. There was already a check before 7ef822cddfe9 to see whether there was an ofp, but only after the format scope has been popped. This commit extends that check by making sure there is an io first. It removes the commented-out bad_ofp label. M pp_sys.c M t/op/write.t commit f922571b226d9a59e677b263d6fda481db5611c4 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 12:41:48 2012 -0700 Make glob.t more resilient It was not tolerating editor temp files with spaces in their names. It was testing the output of <op/*> by comparing it with split /\s/, `echo op/*` on non-Windows non-VMS systems (Unix). `ls op/* | cat` produces more machine-friendly output, so use that. M t/op/glob.t commit 2e4e39b1f407dc989ac979c5aa00bd8a77f7c129 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 12:28:51 2012 -0700 parser.t: Move tests above âAdd tests hereâ M t/comp/parser.t commit ee23553f1b79f6259f9464480592b43a0c56e745 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 12:15:18 2012 -0700 Donât let active formats be freed This crashes: format FOO = @< undef *FOO . $~ = FOO; write The context stack needs to hold a reference count for formats, just as it does for subs. M cop.h M t/op/write.t commit d3810ef8d372a8c7b72ce050c1baa05f368045e6 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 11:24:26 2012 -0700 Fix Devel::Peekâs tests for format changes M ext/Devel-Peek/t/Peek.t commit f32c7e864b6210c7dabe6a78f842c37aa73c56c3 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 01:05:45 2012 -0700 Recursive formats and closures in formats. Formats called recursively were using the same set of lexicals, so the inner call would stomp on the outer calls vars, usually clearing them when exiting. Previous commits prepared a CvDEPTH field for formats. This commit sets it in P(USH|OP)FORMAT and pushes a new pad in enterwrite. This also allows closures to work properly in formats. Formerly they caused assertion failures in cv_clone. Now cv_cloneâs assumptions about CvDEPTH on CvOUTSIDE and find_runcv are met when subs are embed- ded in formats. M cop.h M pp_sys.c M t/comp/form_scope.t commit bb02a38febc60a289c616282d720015be97842a4 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 00:48:00 2012 -0700 Add a depth field to formats Instead of lengthening the struct, we can reuse SvCUR, which is cur- rently unused. M cv.h M dump.c M ext/B/B.xs M sv.h commit dea823b3f7c22fea989211dbe1bed7a34d49e39a Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 00:34:11 2012 -0700 Disallow setting SvPV on formats Setting a the PV on a format is meaningless, as of the previ- ous commit. This frees up SvCUR for other uses. M dump.c M sv.c commit f2da823f484d421a6bb57e32e442b19b553f4b35 Author: Father Chrysostomos <[email protected]> Date: Sun Aug 5 00:15:52 2012 -0700 Make PL_(top|body|form)target PVIVs These are only used for storing a string and an IV. Making them into full-blown SVt_PVFMs is overkill. FmLINES was only being used on these three scalars. So make it use the SvIVX field. struct xpvfm no longer needs an xfm_lines member, because SVt_PVFMs no longer use it. This also causes a TODO test in taint.t to start passing, but I do not fully understand why. But at least thatâs progress. :-) M dump.c M ext/B/B.xs M mg.c M perl.c M sv.h M t/op/taint.t commit 9a7154347977e29a815d93c0097c5a9b660006b2 Author: Father Chrysostomos <[email protected]> Date: Sat Aug 4 18:01:01 2012 -0700 [perl #78550] Fix bad assertion in toke.c:start_subparse The outer âsubâ might actually be a format M t/comp/form_scope.t M toke.c commit 5aec98dfc772975fdb511f380dee9d0b016c16be Author: Father Chrysostomos <[email protected]> Date: Sat Aug 4 17:57:21 2012 -0700 pad.c:cv_clone: Rmv irrelevent part of comment M pad.c commit f91073d438e1f6952add377836e416c47505261f Author: Father Chrysostomos <[email protected]> Date: Sat Aug 4 17:54:32 2012 -0700 pad.c:cv_clone: add assertions The outer sub should always be active and have a pad if it is a sub that is being cloned. Only formats can have an inactive or padless outside. Add assertions to that effect. M pad.c ----------------------------------------------------------------------- Summary of changes: cop.h | 4 ++++ cv.h | 14 +++++++++++--- dump.c | 7 ++----- ext/B/B.xs | 20 +++++++++++++++----- ext/Devel-Peek/t/Peek.t | 4 ++-- mg.c | 6 ++++-- pad.c | 7 ++++--- perl.c | 4 ++-- pp_sys.c | 12 +++++++----- sv.c | 18 +++++------------- sv.h | 10 +++++++--- t/comp/form_scope.t | 19 +++++++++++++++++-- t/comp/parser.t | 4 ++-- t/op/glob.t | 2 +- t/op/taint.t | 5 +---- t/op/write.t | 21 ++++++++++++++++++++- toke.c | 3 --- 17 files changed, 104 insertions(+), 56 deletions(-) diff --git a/cop.h b/cop.h index 041420c..ed55483 100644 --- a/cop.h +++ b/cop.h @@ -627,6 +627,8 @@ struct block_format { cx->blk_format.gv = gv; \ cx->blk_format.retop = (retop); \ cx->blk_format.dfoutgv = PL_defoutgv; \ + if (!CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv); \ + CvDEPTH(cv)++; \ SvREFCNT_inc_void(cx->blk_format.dfoutgv) #define POP_SAVEARRAY() \ @@ -679,6 +681,8 @@ struct block_format { #define POPFORMAT(cx) \ setdefout(cx->blk_format.dfoutgv); \ + CvDEPTH(cx->blk_format.cv)--; \ + if (!CvDEPTH(cx->blk_format.cv)) SvREFCNT_dec(cx->blk_format.cv); \ SvREFCNT_dec(cx->blk_format.dfoutgv); /* eval context */ diff --git a/cv.h b/cv.h index e2644e1..a94d248 100644 --- a/cv.h +++ b/cv.h @@ -61,13 +61,21 @@ See L<perlguts/Autoloading with XSUBs>. (CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv)) #endif #define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv))) +PERL_STATIC_INLINE I32 * +S_CvDEPTHp(const CV * const sv) +{ + return SvTYPE(sv) == SVt_PVCV + ? &((XPVCV*)SvANY(sv))->xcv_depth + : &((XPVCV*)SvANY(sv))->xpv_cur_u.xpvcuru_fmdepth; +} #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define CvDEPTH(sv) (*({const CV *const _cvdepth = (const CV *)sv; \ - assert(SvTYPE(_cvdepth) == SVt_PVCV); \ - &((XPVCV*)SvANY(_cvdepth))->xcv_depth; \ + assert(SvTYPE(_cvdepth) == SVt_PVCV \ + || SvTYPE(_cvdepth) == SVt_PVFM); \ + S_CvDEPTHp(_cvdepth); \ })) #else -# define CvDEPTH(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_depth +# define CvDEPTH(sv) *S_CvDEPTHp((const CV *)sv) #endif #define CvPADLIST(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist #define CvOUTSIDE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside diff --git a/dump.c b/dump.c index 022983d..0c5cc75 100644 --- a/dump.c +++ b/dump.c @@ -1609,7 +1609,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo return; } - if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) { + if (type <= SVt_PVLV && !isGV_with_GP(sv)) { if (SvPVX_const(sv)) { STRLEN delta; if (SvOOK(sv)) { @@ -1920,12 +1920,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); - if (type == SVt_PVCV) - Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); + Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); - if (type == SVt_PVFM) - Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv)); Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); if (nest < maxnest) { do_dump_pad(level+1, file, CvPADLIST(sv), 0); diff --git a/ext/B/B.xs b/ext/B/B.xs index b503611..2c3d7f8 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1446,12 +1446,9 @@ MODULE = B PACKAGE = B::IV #define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max) -#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines) - #define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash) #define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv) #define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file) -#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth) #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist) #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside) #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq) @@ -1504,11 +1501,9 @@ IVX(sv) B::IO::IoTYPE = PVIO_type_ix B::IO::IoFLAGS = PVIO_flags_ix B::AV::MAX = PVAV_max_ix - B::FM::LINES = PVFM_lines_ix B::CV::STASH = PVCV_stash_ix B::CV::GV = PVCV_gv_ix B::CV::FILE = PVCV_file_ix - B::CV::DEPTH = PVCV_depth_ix B::CV::PADLIST = PVCV_padlist_ix B::CV::OUTSIDE = PVCV_outside_ix B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix @@ -1961,6 +1956,17 @@ AvFLAGS(av) #endif +MODULE = B PACKAGE = B::FM PREFIX = Fm + +#if PERL_VERSION > 7 || (PERL_VERSION == 7 && PERL_SUBVERSION >= 3) +# undef FmLINES +# define FmLINES(sv) 0 +#endif + +IV +FmLINES(form) + B::FM form + MODULE = B PACKAGE = B::CV PREFIX = Cv U32 @@ -1976,6 +1982,10 @@ CvSTART(cv) PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv))); +I32 +CvDEPTH(cv) + B::CV cv + void CvXSUB(cv) B::CV cv diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 1d0de0d..f641982 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -690,13 +690,13 @@ do_test('FORMAT', XSUBANY = 0 # $] < 5.009 GVGV::GV = $ADDR\\t"main" :: "PIE" FILE = ".*\\b(?i:peek\\.t)"(?: - DEPTH = 0 + DEPTH = 0)?(?: MUTEXP = $ADDR OWNER = $ADDR)? FLAGS = 0x0 # $] < 5.015 || !thr FLAGS = 0x1000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ - LINES = 0 + LINES = 0 # $] < 5.017_003 PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) OUTSIDE = $ADDR \\(MAIN\\)'); diff --git a/mg.c b/mg.c index 3b4ed1c..2ac49bf 100644 --- a/mg.c +++ b/mg.c @@ -814,7 +814,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ - sv_setsv(sv, PL_bodytarget); + if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); + else sv_setsv(sv, &PL_sv_undef); if (SvTAINTED(PL_bodytarget)) SvTAINTED_on(sv); break; @@ -2542,7 +2543,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '\001': /* ^A */ - sv_setsv(PL_bodytarget, sv); + if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); + else SvOK_off(PL_bodytarget); FmLINES(PL_bodytarget) = 0; if (SvPOK(PL_bodytarget)) { char *s = SvPVX(PL_bodytarget); diff --git a/pad.c b/pad.c index 1e796e7..01813f8 100644 --- a/pad.c +++ b/pad.c @@ -2010,18 +2010,19 @@ Perl_cv_clone(pTHX_ CV *proto) outpad = CvPADLIST(outside) ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth]) : NULL; + assert(outpad || SvTYPE(cv) == SVt_PVFM); for (ix = fpad; ix > 0; ix--) { SV* const namesv = (ix <= fname) ? pname[ix] : NULL; SV *sv = NULL; if (namesv && namesv != &PL_sv_undef) { /* lexical */ if (SvFAKE(namesv)) { /* lexical from outside? */ - /* formats may have an inactive, or even undefined, parent, - while my $x if $false can leave an active var marked as - stale. And state vars are always available */ + /* formats may have an inactive, or even undefined, parent; + but state vars are always available. */ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) && !CvDEPTH(outside)) ) { + assert(SvTYPE(cv) == SVt_PVFM); Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%"SVf"\" is not available", namesv); sv = NULL; diff --git a/perl.c b/perl.c index d8b8aca..d836b0b 100644 --- a/perl.c +++ b/perl.c @@ -4137,9 +4137,9 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; - PL_toptarget = newSV_type(SVt_PVFM); + PL_toptarget = newSV_type(SVt_PVIV); sv_setpvs(PL_toptarget, ""); - PL_bodytarget = newSV_type(SVt_PVFM); + PL_bodytarget = newSV_type(SVt_PVIV); sv_setpvs(PL_bodytarget, ""); PL_formtarget = PL_bodytarget; diff --git a/pp_sys.c b/pp_sys.c index a11eced..85fa251 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1335,8 +1335,12 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx, retop); + if (CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1473,9 +1477,8 @@ PP(pp_leavewrite) SP = newsp; /* ignore retval of formline */ LEAVE; - fp = IoOFP(io); - if (!fp) { - if (IoIFP(io)) + if (!io || !(fp = IoOFP(io))) { + if (io && IoIFP(io)) report_wrongway_fh(gv, '<'); else report_evil_fh(gv); @@ -1496,7 +1499,6 @@ PP(pp_leavewrite) PUSHs(&PL_sv_yes); } } - /* bad_ofp: */ PL_formtarget = PL_bodytarget; PERL_UNUSED_VAR(gimme); RETURNOP(retop); diff --git a/sv.c b/sv.c index dd4f19a..8d5d62b 100644 --- a/sv.c +++ b/sv.c @@ -3984,15 +3984,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } goto undef_sstr; - case SVt_PVFM: -#ifdef PERL_OLD_COPY_ON_WRITE - if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { - if (dtype < SVt_PVIV) - sv_upgrade(dstr, SVt_PVIV); - break; - } - /* Fall through */ -#endif case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -4045,7 +4036,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) dtype = SvTYPE(dstr); sflags = SvFLAGS(sstr); - if (dtype == SVt_PVCV || dtype == SVt_PVFM) { + if (dtype == SVt_PVCV) { /* Assigning to a subroutine sets the prototype. */ if (SvOK(sstr)) { STRLEN len; @@ -4060,7 +4051,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else { SvOK_off(dstr); } - } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { + } + else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) { const char * const type = sv_reftype(dstr,0); if (PL_op) /* diag_listed_as: Cannot copy to %s */ @@ -4203,7 +4195,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM)) + && SvTYPE(sstr) >= SVt_PVIV)) : 1) #endif ) { @@ -9052,7 +9044,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + if (SvTYPE(sv) > SVt_PVLV || isGV_with_GP(sv)) /* diag_listed_as: Can't coerce %s to %s in %s */ Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), diff --git a/sv.h b/sv.h index 056d43b..4c9bc55 100644 --- a/sv.h +++ b/sv.h @@ -415,9 +415,14 @@ perform the upgrade if necessary. See C<svtype>. #define _XPV_HEAD \ HV* xmg_stash; /* class package */ \ union _xmgu xmg_u; \ - STRLEN xpv_cur; /* length of svu_pv as a C string */ \ + union { \ + STRLEN xpvcuru_cur; /* length of svu_pv as a C string */ \ + I32 xpvcuru_fmdepth; \ + } xpv_cur_u; \ STRLEN xpv_len /* allocated size */ +#define xpv_cur xpv_cur_u.xpvcuru_cur + union _xnvu { NV xnv_nv; /* numeric value, if any */ HV * xgv_stash; @@ -520,7 +525,6 @@ typedef U16 cv_flags_t; struct xpvfm { _XPV_HEAD; _XPVCV_COMMON; - IV xfm_lines; }; @@ -1387,7 +1391,7 @@ sv_force_normal does nothing. #endif -#define FmLINES(sv) ((XPVFM*) SvANY(sv))->xfm_lines +#define FmLINES(sv) ((XPVIV*) SvANY(sv))->xiv_iv #define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type #define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t index 809e0d2..4a46796 100644 --- a/t/comp/form_scope.t +++ b/t/comp/form_scope.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\n"; +print "1..13\n"; # Tests bug #22977. Test case from Dave Mitchell. sub f ($); @@ -118,12 +118,27 @@ undef &x; print "ok 9 - closure var not available when outer sub is undefined\n"; } +format STDOUT7 = +@<<<<<<<<<<<<<<<<<<<<<<<<<<< +do { my $x = "ok 10 - closure inside format"; sub { $x }->() } +. +*STDOUT = *STDOUT7{FORMAT}; +write; + +$testn = 12; +format STDOUT8 = +@<<<< - recursive formats +do { my $t = "ok " . $testn--; write if $t =~ 12; $t} +. +*STDOUT = *STDOUT8{FORMAT}; +write; + # This is a variation of bug #22977, which crashes or fails an assertion # up to 5.16. # Keep this test last if you want test numbers to be sane. BEGIN { \&END } END { - my $test = "ok 10"; + my $test = "ok 13"; *STDOUT = *STDOUT5{FORMAT}; write; format STDOUT5 = diff --git a/t/comp/parser.t b/t/comp/parser.t index 9ae7b75..ac6742e 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -366,8 +366,6 @@ eval q{ }; is($@, "", "multiline whitespace inside substitute expression"); -# Add new tests HERE: - eval '@A =~ s/a/b/; # compilation error sub tahi {} sub rua; @@ -390,6 +388,8 @@ is $::{waru}, undef, 'sub w attr+proto ignored after compilation error'; is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error'; is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error'; +# Add new tests HERE (above this line) + # bug #74022: Loop on characters in \p{OtherIDContinue} # This test hangs if it fails. eval chr 0x387; diff --git a/t/op/glob.t b/t/op/glob.t index f122fa9..8ad827e 100644 --- a/t/op/glob.t +++ b/t/op/glob.t @@ -20,7 +20,7 @@ elsif ($^O eq 'VMS') { } else { map { $files{$_}++ } <op/*>; - map { delete $files{$_} } split /[\s\n]/, `echo op/*`; + map { delete $files{$_} } split /\n/, `ls op/* | cat`; } ok( !(keys(%files)),'leftover op/* files' ) or diag(join(' ',sort keys %files)); diff --git a/t/op/taint.t b/t/op/taint.t index c8537fc..0e89c1f 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -2050,10 +2050,7 @@ end formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); isnt_tainted($^A, "accumulator still untainted"); formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); - TODO: { - local $::TODO = "get magic handled too late?"; - is_tainted($^A, "the accumulator should be tainted already"); - } + is_tainted($^A, "the accumulator should be tainted already"); is_tainted($^A, "tainted formline picture makes a tainted accumulator"); } diff --git a/t/op/write.t b/t/op/write.t index 29b5b8a..a648902 100644 --- a/t/op/write.t +++ b/t/op/write.t @@ -61,7 +61,7 @@ for my $tref ( @NumTests ){ my $bas_tests = 20; # number of tests in section 3 -my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96; +my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 2; # number of tests in section 4 my $hmb_tests = 35; @@ -984,6 +984,25 @@ return close RT73690_2 or die "Could not close: $!"; })[0]; +open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp"; +select +(select(UNDEF), $~ = "UNDEFFORMAT")[0]; +format UNDEFFORMAT = +@ +undef *UNDEFFORMAT +. +write UNDEF; +pass "active format cannot be freed"; + +select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0]; +format UNDEFFORMAT2 = +@ +close UNDEF or die "Could not close: $!"; undef *UNDEF +. +write UNDEF; +pass "freeing current handle in format"; +undef $^A; + + ############################# ## Section 4 ## Add new tests *above* here diff --git a/toke.c b/toke.c index 9deac94..9645ac6 100644 --- a/toke.c +++ b/toke.c @@ -10742,9 +10742,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) const I32 oldsavestack_ix = PL_savestack_ix; CV* const outsidecv = PL_compcv; - if (PL_compcv) { - assert(SvTYPE(PL_compcv) == SVt_PVCV); - } SAVEI32(PL_subline); save_item(PL_subname); SAVESPTR(PL_compcv); -- Perl5 Master Repository
