diff options
| -rw-r--r-- | dump.c | 1 | ||||
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | mg.c | 1 | ||||
| -rw-r--r-- | pod/perldelta.pod | 8 | ||||
| -rw-r--r-- | pp_ctl.c | 49 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | sv.h | 10 | ||||
| -rw-r--r-- | t/op/index.t | 23 |
8 files changed, 63 insertions, 33 deletions
@@ -1627,7 +1627,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo case SVt_PVCV: case SVt_PVFM: append_flags(d, CvFLAGS(sv), cv_flags_names); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); break; case SVt_PVHV: append_flags(d, flags, hv_flags_names); @@ -1721,7 +1721,7 @@ snR |char * |bytes_to_uni |NN const U8 *start|STRLEN len|NN char *dest #if defined(PERL_IN_PP_CTL_C) sR |OP* |docatch |NULLOK OP *o sR |OP* |dofindlabel |NN OP *o|NN const char *label|NN OP **opstack|NN OP **oplimit -s |void |doparseform |NN SV *sv +s |MAGIC *|doparseform |NN SV *sv snR |bool |num_overflow |NV value|I32 fldsize|I32 frcsize sR |I32 |dopoptoeval |I32 startingblock sR |I32 |dopoptogiven |I32 startingblock @@ -2415,7 +2415,6 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) SvVALID_off(sv); } else { assert(type == PERL_MAGIC_fm); - SvCOMPILED_off(sv); } return sv_unmagic(sv, type); } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 845f1a0129..02669deed3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -278,13 +278,15 @@ XXX Changes which affect the interface available to C<XS> code go here. Other significant internal changes for future core maintainers should be noted as well. -[ List each test improvement as a =item entry ] - =over 4 =item * -XXX +The compiled representation of formats is now stored via the mg_ptr of +their PERL_MAGIC_fm. Previously it was stored in the string buffer, +beyond SvLEN(), the regular end of the string. SvCOMPILED() and +SvCOMPILED_{on,off}() now exist solely for compatibility for XS code. +The first is always 0, the other two now no-ops. =back @@ -34,10 +34,6 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#ifndef WORD_ALIGN -#define WORD_ALIGN sizeof(U32) -#endif - #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -548,16 +544,27 @@ PP(pp_formline) bool targ_is_utf8 = FALSE; SV * nsv = NULL; const char *fmt; + MAGIC *mg = NULL; + + if (SvTYPE(tmpForm) >= SVt_PVMG) { + /* This might, of course, still return NULL. */ + mg = mg_find(tmpForm, PERL_MAGIC_fm); + } else { + sv_upgrade(tmpForm, SVt_PVMG); + } - if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { + if(!mg) { if (SvREADONLY(tmpForm)) { SvREADONLY_off(tmpForm); - doparseform(tmpForm); + mg = doparseform(tmpForm); SvREADONLY_on(tmpForm); } else - doparseform(tmpForm); + mg = doparseform(tmpForm); + assert(mg); } + fpc = (U32*)mg->mg_ptr; + SvPV_force(PL_formtarget, len); if (SvTAINTED(tmpForm)) SvTAINTED_on(PL_formtarget); @@ -566,8 +573,6 @@ PP(pp_formline) t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV_const(tmpForm, len); - /* need to jump to the next word */ - fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); for (;;) { DEBUG_f( { @@ -4914,7 +4919,7 @@ PP(pp_break) RETURNOP(cx->blk_givwhen.leave_op); } -static void +static MAGIC * S_doparseform(pTHX_ SV *sv) { STRLEN len; @@ -4932,6 +4937,7 @@ S_doparseform(pTHX_ SV *sv) bool ischop; bool unchopnum = FALSE; int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + MAGIC *mg; PERL_ARGS_ASSERT_DOPARSEFORM; @@ -5117,19 +5123,22 @@ S_doparseform(pTHX_ SV *sv) assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ arg = fpc - fops; - { /* need to jump to the next word */ - int z; - z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; - SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); - s = SvPVX(sv) + SvCUR(sv) + z; - } - Copy(fops, s, arg, U32); - Safefree(fops); - sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0); - SvCOMPILED_on(sv); + + /* If we pass the length in to sv_magicext() it will copy the buffer for us. + We don't need that, so by setting the length on return we "donate" the + buffer to the magic, avoiding an allocation. We could realloc() the + buffer to the exact size used, but that feels like it's not worth it + (particularly if the rumours are true and some realloc() implementations + don't shrink blocks). However, set the true length used in mg_len so that + mg_dup only allocates and copies what's actually needed. */ + mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, + (const char *const) fops, 0); + mg->mg_len = arg * sizeof(U32); if (unchopnum && repeat) Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); + + return mg; } @@ -5710,7 +5710,7 @@ STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **opli #define PERL_ARGS_ASSERT_DOFINDLABEL \ assert(o); assert(label); assert(opstack); assert(oplimit) -STATIC void S_doparseform(pTHX_ SV *sv) +STATIC MAGIC * S_doparseform(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOPARSEFORM \ assert(sv) @@ -388,8 +388,6 @@ perform the upgrade if necessary. See C<svtype>. #define SVpav_REIFY 0x80000000 /* can become real */ /* PVHV */ #define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */ -/* PVFM */ -#define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */ /* PVGV when SVpbm_VALID is true */ #define SVpbm_TAIL 0x80000000 /* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */ @@ -923,9 +921,11 @@ the scalar's value cannot change unless written to. #define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVp_SCREAM) #define SvSCREAM_off(sv) (SvFLAGS(sv) &= ~SVp_SCREAM) -#define SvCOMPILED(sv) (SvFLAGS(sv) & SVpfm_COMPILED) -#define SvCOMPILED_on(sv) (SvFLAGS(sv) |= SVpfm_COMPILED) -#define SvCOMPILED_off(sv) (SvFLAGS(sv) &= ~SVpfm_COMPILED) +#ifndef PERL_CORE +# define SvCOMPILED(sv) 0 +# define SvCOMPILED_on(sv) +# define SvCOMPILED_off(sv) +#endif #define SvEVALED(sv) (SvFLAGS(sv) & SVrepl_EVAL) #define SvEVALED_on(sv) (SvFLAGS(sv) |= SVrepl_EVAL) diff --git a/t/op/index.t b/t/op/index.t index 5ef69fcb50..c8aafcf061 100644 --- a/t/op/index.t +++ b/t/op/index.t @@ -7,7 +7,7 @@ BEGIN { } use strict; -plan( tests => 113 ); +plan( tests => 120 ); run_tests() unless caller; @@ -203,4 +203,25 @@ SKIP: { 'UTF-8 cache handles offset beyond the end of the string'); } +# RT #89218 +use constant {PVBM => 'galumphing', PVBM2 => 'bang'}; + +sub index_it { + is(index('galumphing', PVBM), 0, + "index isn't confused by format compilation"); +} + +index_it(); +is($^A, '', '$^A is empty'); +formline PVBM; +is($^A, 'galumphing', "formline isn't confused by index compilation"); +index_it(); + +$^A = ''; +# must not do index here before formline. +is($^A, '', '$^A is empty'); +formline PVBM2; +is($^A, 'bang', "formline isn't confused by index compilation"); +is(index('bang', PVBM2), 0, "index isn't confused by format compilation"); + } |