In perl.git, the branch ilmari/remove-commaless-format-variable-list has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/ffdd6efb40dd7da110cee1493f9699a1fad2ab01?hp=62038ea1a3197e4a74299a53290b2240fdad21d2> discards 62038ea1a3197e4a74299a53290b2240fdad21d2 (commit) - Log ----------------------------------------------------------------- commit ffdd6efb40dd7da110cee1493f9699a1fad2ab01 Author: Dagfinn Ilmari Mannsåker <[email protected]> Date: Sat Nov 12 17:08:18 2016 +0100 Remove deprecated comma-less format variable lists This has been issuing a deprecation warning since perl 5.000. ----------------------------------------------------------------------- Summary of changes: cop.h | 8 +++-- dump.c | 19 ++---------- ext/Devel-Peek/Peek.pm | 4 +-- ext/Devel-Peek/t/Peek.t | 13 ++------- gv.h | 2 +- inline.h | 7 +++-- mg.c | 10 ++----- pod/perlguts.pod | 16 +++++----- pp_hot.c | 4 ++- regcomp.c | 6 +++- sv.c | 4 +-- sv.h | 77 +++++++++++++------------------------------------ toke.c | 27 +++++++++++++---- universal.c | 17 +++++++---- util.c | 35 +++++++--------------- 15 files changed, 102 insertions(+), 147 deletions(-) diff --git a/cop.h b/cop.h index b371379..0443e24 100644 --- a/cop.h +++ b/cop.h @@ -640,8 +640,11 @@ struct block_eval { blku_gimme is actually also only 2 bits, so could be merged with something. */ -#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x7F) -#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) +/* blk_u16 bit usage for eval contexts: */ + +#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x3F) /* saved PL in_eval */ +#define CxEVAL_TXT_REFCNTED(cx) (((cx)->blk_u16) & 0x40) /* cur_text rc++ */ +#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) /* type of eval op */ /* loop context */ struct block_loop { @@ -961,6 +964,7 @@ L<perlcall>. #define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */ #define EVAL_INREQUIRE 8 /* The code is being required. */ #define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */ +/* if adding extra bits, make sure they can fit in CxOLD_OP_TYPE() */ /* Support for switching (stack and block) contexts. * This ensures magic doesn't invalidate local stack and cx pointers. diff --git a/dump.c b/dump.c index 3e1b011..1c64449 100644 --- a/dump.c +++ b/dump.c @@ -657,12 +657,8 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) PERL_ARGS_ASSERT_DO_PMOP_DUMP; - if (!pm) { - Perl_dump_indent(aTHX_ level, file, "{}\n"); + if (!pm) return; - } - Perl_dump_indent(aTHX_ level, file, "{\n"); - level++; if (pm->op_pmflags & PMf_ONCE) ch = '?'; else @@ -698,8 +694,6 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); SvREFCNT_dec_NN(tmpsv); } - - Perl_dump_indent(aTHX_ level-1, file, "}\n"); } const struct flag_to_name pmflags_flags_names[] = { @@ -1514,16 +1508,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } } /* FALLTHROUGH */ + case SVt_PVMG: default: - evaled_or_uv: - if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); break; - case SVt_PVMG: - if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); - if (SvVALID(sv)) sv_catpv(d, "VALID,"); - /* FALLTHROUGH */ - goto evaled_or_uv; + case SVt_PVAV: break; } @@ -1675,8 +1664,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (void)PerlIO_putc(file, '\n'); Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); - Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", - SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); SvPVCLEAR(d); if (AvREAL(sv)) sv_catpv(d, ",REAL"); if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); diff --git a/ext/Devel-Peek/Peek.pm b/ext/Devel-Peek/Peek.pm index f3ce70f..4ce8b45 100644 --- a/ext/Devel-Peek/Peek.pm +++ b/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.25'; +$VERSION = '1.26'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -354,7 +354,6 @@ The output: ARRAY = 0xc7e820 FILL = 0 MAX = 0 - ARYLEN = 0x0 FLAGS = (REAL) Elt No. 0 SV = IV(0xc70f88) at 0xc70f98 @@ -386,7 +385,6 @@ The output: ARRAY = 0x1585820 FILL = 1 MAX = 1 - ARYLEN = 0x0 FLAGS = (REAL) Elt No. 0 SV = IV(0x1577f88) at 0x1577f98 diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 41898fe..07f6510 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -262,7 +262,6 @@ do_test('reference to array', ARRAY = $ADDR FILL = 1 MAX = 1 - ARYLEN = 0x0 FLAGS = \\(REAL\\) Elt No. 0 SV = IV\\($ADDR\\) at $ADDR @@ -936,7 +935,6 @@ SV = PVAV\($ADDR\) at $ADDR ARRAY = $ADDR FILL = 2 MAX = 3 - ARYLEN = 0x0 FLAGS = \(REAL\) Elt No. 0 SV = IV\($ADDR\) at $ADDR @@ -962,7 +960,6 @@ SV = PVAV\($ADDR\) at $ADDR ARRAY = $ADDR FILL = 2 MAX = 3 - ARYLEN = 0x0 FLAGS = \(REAL\) Elt No. 0 SV = IV\($ADDR\) at $ADDR @@ -1048,14 +1045,10 @@ unless ($Config{useithreads}) { eval 'index "", perl'; - # FIXME - really this shouldn't say EVALED. It's a false posistive on - # 0x40000000 being used for several things, not a flag for "I'm in a string - # eval" - do_test('string constant now an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "rule"\\\0 CUR = 4 LEN = \d+ @@ -1075,7 +1068,7 @@ unless ($Config{useithreads}) { do_test('string constant still an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "rule"\\\0 CUR = 4 LEN = \d+ @@ -1115,7 +1108,7 @@ unless ($Config{useithreads}) { my $want = 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 6 - FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) PV = $ADDR "foam"\\\0 CUR = 4 LEN = \d+ diff --git a/gv.h b/gv.h index e3357bc..0b08b68 100644 --- a/gv.h +++ b/gv.h @@ -52,7 +52,7 @@ struct gp { (*({ GV * const _gvname_hek = (GV *) (gv); \ assert(isGV_with_GP(_gvname_hek)); \ assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \ - assert(!SvVALID(_gvname_hek)); \ + assert(!SvVALID((SV*)_gvname_hek)); \ &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \ })) # define GvNAME_get(gv) ({ assert(GvNAME_HEK(gv)); (char *)HEK_KEY(GvNAME_HEK(gv)); }) diff --git a/inline.h b/inline.h index adcd85d..5d516da 100644 --- a/inline.h +++ b/inline.h @@ -1490,9 +1490,9 @@ S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv) cx->blk_eval.cv = NULL; /* later set by doeval_compile() */ cx->blk_eval.cur_top_env = PL_top_env; - assert(!(PL_in_eval & ~ 0x7F)); + assert(!(PL_in_eval & ~ 0x3F)); assert(!(PL_op->op_type & ~0x1FF)); - cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); + cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7); } @@ -1505,9 +1505,10 @@ S_cx_popeval(pTHX_ PERL_CONTEXT *cx) assert(CxTYPE(cx) == CXt_EVAL); PL_in_eval = CxOLD_IN_EVAL(cx); + assert(!(PL_in_eval & 0xc0)); PL_eval_root = cx->blk_eval.old_eval_root; sv = cx->blk_eval.cur_text; - if (sv && SvSCREAM(sv)) { + if (sv && CxEVAL_TXT_REFCNTED(cx)) { cx->blk_eval.cur_text = NULL; SvREFCNT_dec_NN(sv); } diff --git a/mg.c b/mg.c index a0ee39d..d0d3b9d 100644 --- a/mg.c +++ b/mg.c @@ -2443,13 +2443,9 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETREGEXP; - if (type == PERL_MAGIC_qr) { - } else if (type == PERL_MAGIC_bm) { - SvTAIL_off(sv); - SvVALID_off(sv); - } else { - assert(type == PERL_MAGIC_fm); - } + assert( type == PERL_MAGIC_fm + || type == PERL_MAGIC_qr + || type == PERL_MAGIC_bm); return sv_unmagic(sv, type); } diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 7f72d65..2da946c 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1124,16 +1124,16 @@ applied to that variable. The C<MGVTBL> has five (or sometimes eight) pointers to the following routine types: - int (*svt_get)(SV* sv, MAGIC* mg); - int (*svt_set)(SV* sv, MAGIC* mg); - U32 (*svt_len)(SV* sv, MAGIC* mg); - int (*svt_clear)(SV* sv, MAGIC* mg); - int (*svt_free)(SV* sv, MAGIC* mg); + int (*svt_get) (pTHX_ SV* sv, MAGIC* mg); + int (*svt_set) (pTHX_ SV* sv, MAGIC* mg); + U32 (*svt_len) (pTHX_ SV* sv, MAGIC* mg); + int (*svt_clear)(pTHX_ SV* sv, MAGIC* mg); + int (*svt_free) (pTHX_ SV* sv, MAGIC* mg); - int (*svt_copy)(SV *sv, MAGIC* mg, SV *nsv, + int (*svt_copy) (pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *name, I32 namlen); - int (*svt_dup)(MAGIC *mg, CLONE_PARAMS *param); - int (*svt_local)(SV *nsv, MAGIC *mg); + int (*svt_dup) (pTHX_ MAGIC *mg, CLONE_PARAMS *param); + int (*svt_local)(pTHX_ SV *nsv, MAGIC *mg); This MGVTBL structure is set at compile-time in F<perl.h> and there are diff --git a/pp_hot.c b/pp_hot.c index cc86d0a..ad0920c 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -4365,6 +4365,8 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) return sv; } +extern char PL_isa_DOES[]; + PERL_STATIC_INLINE HV * S_opmethod_stash(pTHX_ SV* meth) { @@ -4443,7 +4445,7 @@ S_opmethod_stash(pTHX_ SV* meth) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference", - SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa")) + SVfARG((SvPVX(meth) == PL_isa_DOES) ? newSVpvs_flags("DOES", SVs_TEMP) : meth)); } diff --git a/regcomp.c b/regcomp.c index e9c7972..ac66432 100644 --- a/regcomp.c +++ b/regcomp.c @@ -6677,7 +6677,11 @@ S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, calculate it.*/ ml = minlen ? *(minlen) : (SSize_t)longest_length; *rx_end_shift = ml - offset - - longest_length + (SvTAIL(sv_longest) != 0) + - longest_length + /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL + * intead? - DAPM + + (SvTAIL(sv_longest) != 0) + */ + lookbehind; t = (eol/* Can't have SEOL and MULTI */ diff --git a/sv.c b/sv.c index b2403e3..2257708 100644 --- a/sv.c +++ b/sv.c @@ -4741,8 +4741,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) } if (sflags & SVp_IOK) { SvIV_set(dstr, SvIVX(sstr)); - /* Must do this otherwise some other overloaded use of 0x80000000 - gets confused. I guess SVpbm_VALID */ if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } @@ -14150,7 +14148,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_EVAL: ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, param); - /* XXX should this sv_dup_inc? Or only if SvSCREAM ???? */ + /* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */ ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); /* XXX what do do with cur_top_env ???? */ diff --git a/sv.h b/sv.h index d45a4a9..b97c175 100644 --- a/sv.h +++ b/sv.h @@ -160,9 +160,7 @@ typedef enum { #define SVt_MASK 0xf /* smallest bitmask that covers all types */ #ifndef PERL_CORE -/* Although Fast Boyer Moore tables are now being stored in PVGVs, for most - purposes external code wanting to consider PVBM probably needs to think of - PVMG instead. */ +/* Fast Boyer Moore tables are now stored in magic attached to PVMGs */ # define SVt_PVBM SVt_PVMG /* Anything wanting to create a reference from clean should ensure that it has a scalar of type SVt_IV now: */ @@ -369,8 +367,7 @@ perform the upgrade if necessary. See C<L</svtype>>. #define SVp_IOK 0x00001000 /* has valid non-public integer value */ #define SVp_NOK 0x00002000 /* has valid non-public numeric value */ #define SVp_POK 0x00004000 /* has valid non-public pointer value */ -#define SVp_SCREAM 0x00008000 /* method name is DOES */ - /* eval cx text is ref counted */ +#define SVp_SCREAM 0x00008000 /* currently unused on plain scalars */ #define SVphv_CLONEABLE SVp_SCREAM /* PVHV (stashes) clone its objects */ #define SVpgv_GP SVp_SCREAM /* GV has a valid GP */ #define SVprv_PCS_IMPORTED SVp_SCREAM /* RV is a proxy for a constant @@ -438,28 +435,10 @@ perform the upgrade if necessary. See C<L</svtype>>. /* Some private flags. */ -/* The SVp_SCREAM|SVpbm_VALID (0x40008000) combination is up for grabs. - Formerly it was used for pad names, but now it is available. The core - is careful to avoid setting both flags. - - SVf_POK, SVp_POK also set: - 0x00004400 Normal - 0x0000C400 method name for DOES (SvSCREAM) - 0x40004400 FBM compiled (SvVALID) - 0x4000C400 *** Formerly used for pad names *** - - 0x00008000 GV with GP - 0x00008800 RV with PCS imported -*/ /* PVAV */ #define SVpav_REAL 0x40000000 /* free old entries */ /* PVHV */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */ -/* This is only set true on a PVGV when it's playing "PVBM", but is tested for - on any regular scalar (anything <= PVLV) */ -#define SVpbm_VALID 0x40000000 -/* Only used in toke.c on an SV stored in PL_lex_repl */ -#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */ /* IV, PVIV, PVNV, PVMG, PVGV and (I assume) PVLV */ #define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */ @@ -467,8 +446,6 @@ perform the upgrade if necessary. See C<L</svtype>>. #define SVpav_REIFY 0x80000000 /* can become real */ /* PVHV */ #define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */ -/* PVGV when SVpbm_VALID is true */ -#define SVpbm_TAIL 0x80000000 /* string has a fake "\n" appended */ /* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */ #define SVprv_WEAKREF 0x80000000 /* Weak reference */ /* pad name vars only */ @@ -488,12 +465,15 @@ union _xnvu { NV xnv_nv; /* numeric value, if any */ HV * xgv_stash; line_t xnv_lines; /* used internally by S_scan_subst() */ + bool xnv_bm_tail; /* an SvVALID (BM) SV has an implicit "\n" */ }; union _xivu { IV xivu_iv; /* integer value */ UV xivu_uv; HEK * xivu_namehek; /* xpvlv, xpvgv: GvNAME */ + bool xivu_eval_seen; /* used internally by S_scan_subst() */ + }; union _xmgu { @@ -561,8 +541,8 @@ struct xpvinvlist { the list, merely toggle this flag */ }; -/* This structure works in 3 ways - regular scalar, GV with GP, or fast - Boyer-Moore. */ +/* This structure works in 2 ways - regular scalar, or GV with GP */ + struct xpvgv { _XPV_HEAD; union _xivu xiv_u; @@ -1122,44 +1102,27 @@ object type. Exposed to perl code via Internals::SvREADONLY(). # define SvCOMPILED_off(sv) #endif -#define SvEVALED(sv) (SvFLAGS(sv) & SVrepl_EVAL) -#define SvEVALED_on(sv) (SvFLAGS(sv) |= SVrepl_EVAL) -#define SvEVALED_off(sv) (SvFLAGS(sv) &= ~SVrepl_EVAL) #if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define SvVALID(sv) ({ const SV *const _svvalid = (const SV*)(sv); \ - if (SvFLAGS(_svvalid) & SVpbm_VALID && !SvSCREAM(_svvalid)) \ - assert(!isGV_with_GP(_svvalid)); \ - (SvFLAGS(_svvalid) & SVpbm_VALID); \ - }) -# define SvVALID_on(sv) ({ SV *const _svvalid = MUTABLE_SV(sv); \ - assert(!isGV_with_GP(_svvalid)); \ - assert(!SvSCREAM(_svvalid)); \ - (SvFLAGS(_svvalid) |= SVpbm_VALID); \ - }) -# define SvVALID_off(sv) ({ SV *const _svvalid = MUTABLE_SV(sv); \ - assert(!isGV_with_GP(_svvalid)); \ - assert(!SvSCREAM(_svvalid)); \ - (SvFLAGS(_svvalid) &= ~SVpbm_VALID); \ - }) - # define SvTAIL(sv) ({ const SV *const _svtail = (const SV *)(sv); \ assert(SvTYPE(_svtail) != SVt_PVAV); \ assert(SvTYPE(_svtail) != SVt_PVHV); \ - assert(!SvSCREAM(_svtail)); \ - (SvFLAGS(sv) & (SVpbm_TAIL|SVpbm_VALID)) \ - == (SVpbm_TAIL|SVpbm_VALID); \ + assert(!(SvFLAGS(_svtail) & (SVf_NOK|SVp_NOK))); \ + assert(SvVALID(_svtail)); \ + ((XPVNV*)SvANY(_svtail))->xnv_u.xnv_bm_tail; \ }) #else -# define SvVALID(sv) ((SvFLAGS(sv) & SVpbm_VALID) && !SvSCREAM(sv)) -# define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID) -# define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID) -# define SvTAIL(sv) ((SvFLAGS(sv) & (SVpbm_TAIL|SVpbm_VALID)) \ - == (SVpbm_TAIL|SVpbm_VALID)) - +# define SvTAIL(_svtail) (((XPVNV*)SvANY(_svtail))->xnv_u.xnv_bm_tail) #endif -#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL) -#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL) + +/* Does the SV have a Boyer-Moore table attached as magic? + * 'VALID' is a poor name, but is kept for historical reasons. */ +#define SvVALID(_svvalid) ( \ + SvSMAGICAL(_svvalid) \ + && SvMAGIC(_svvalid) \ + && (SvMAGIC(_svvalid)->mg_type == PERL_MAGIC_bm \ + || mg_find(_svvalid, PERL_MAGIC_bm)) \ + ) #define SvRVx(sv) SvRV(sv) diff --git a/toke.c b/toke.c index bb4b388..c301a69 100644 --- a/toke.c +++ b/toke.c @@ -88,6 +88,11 @@ Individual members of C<PL_parser> have their own documentation. # define PL_nexttype (PL_parser->nexttype) # define PL_nextval (PL_parser->nextval) + +#define SvEVALED(sv) \ + (SvTYPE(sv) >= SVt_PVNV \ + && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen) + static const char* const ident_too_long = "Identifier too long"; # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke] @@ -9350,6 +9355,7 @@ S_scan_subst(pTHX_ char *start) PMOP *pm; I32 first_start; line_t first_line; + line_t linediff = 0; I32 es = 0; char charset = '\0'; /* character set modifier */ unsigned int x_mod_count = 0; @@ -9413,15 +9419,24 @@ S_scan_subst(pTHX_ char *start) sv_catpvs(repl, "{"); sv_catsv(repl, PL_parser->lex_sub_repl); sv_catpvs(repl, "}"); - SvEVALED_on(repl); + ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen = 1; SvREFCNT_dec(PL_parser->lex_sub_repl); PL_parser->lex_sub_repl = repl; + es = 1; } - if (CopLINE(PL_curcop) != first_line) { - sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV); - ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = - CopLINE(PL_curcop) - first_line; + + + linediff = CopLINE(PL_curcop) - first_line; + if (linediff) CopLINE_set(PL_curcop, first_line); + + if (linediff || es) { + /* the IVX field indicates that the replacement string is a s///e; + * the NVX field indicates how many src code lines the replacement + * spreads over */ + sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV); + ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0; + ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen = es; } PL_lex_op = (OP*)pm; @@ -9696,7 +9711,7 @@ S_scan_heredoc(pTHX_ char *s) && cx->blk_eval.cur_text == linestr) { cx->blk_eval.cur_text = newSVsv(linestr); - SvSCREAM_on(cx->blk_eval.cur_text); + cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */ } /* Copy everything from s onwards back to d. */ Move(s,d,bufend-s + 1,char); diff --git a/universal.c b/universal.c index 345b75e..b88d3e2 100644 --- a/universal.c +++ b/universal.c @@ -184,6 +184,10 @@ The SV can be a Perl object or the name of a Perl class. #include "XSUB.h" +/* a special string address whose value is "isa", but whicb perl knows + * to treat as if it were really "DOES" */ +char PL_isa_DOES[] = "isa"; + bool Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) { @@ -222,11 +226,14 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) PUSHs(namesv); PUTBACK; - methodname = newSVpvs_flags("isa", SVs_TEMP); - /* ugly hack: use the SvSCREAM flag so S_method_common - * can figure out we're calling DOES() and not isa(), - * and report eventual errors correctly. --rgs */ - SvSCREAM_on(methodname); + /* create a PV with value "isa", but with a special address + * so that perl knows were' realling doing "DOES" instead */ + methodname = newSV_type(SVt_PV); + SvLEN(methodname) = 0; + SvCUR(methodname) = strlen(PL_isa_DOES); + SvPVX(methodname) = PL_isa_DOES; + SvPOK_on(methodname); + sv_2mortal(methodname); call_sv(methodname, G_SCALAR | G_METHOD); SPAGAIN; diff --git a/util.c b/util.c index a69ddad..fb2ddec 100644 --- a/util.c +++ b/util.c @@ -731,21 +731,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) SvUPGRADE(sv, SVt_PVMG); SvIOK_off(sv); SvNOK_off(sv); - SvVALID_on(sv); - /* "deep magic", the comment used to add. The use of MAGIC itself isn't - really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2) - to call SvVALID_off() if the scalar was assigned to. - - The comment itself (and "deeper magic" below) date back to - 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on - str->str_pok |= 2; - where the magic (presumably) was that the scalar had a BM table hidden - inside itself. - - As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store - the table instead of the previous (somewhat hacky) approach of co-opting - the string buffer and storing it after the string. */ + /* add PERL_MAGIC_bm magic holding the FBM lookup table */ assert(!mg_find(sv, PERL_MAGIC_bm)); mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); @@ -780,8 +767,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) } } BmUSEFUL(sv) = 100; /* Initial value */ - if (flags & FBMcf_TAIL) - SvTAIL_on(sv); + ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL); DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", s[rarest], (UV)rarest)); } @@ -825,11 +811,12 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); STRLEN littlelen = l; const I32 multiline = flags & FBMrf_MULTILINE; + bool tail = SvVALID(littlestr) ? cBOOL(SvTAIL(littlestr)) : FALSE; PERL_ARGS_ASSERT_FBM_INSTR; if ((STRLEN)(bigend - big) < littlelen) { - if ( SvTAIL(littlestr) + if ( tail && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && @@ -843,19 +830,19 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U return (char*)big; /* Cannot be SvTAIL! */ case 1: - if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + if (tail && !multiline) /* Anchor only! */ /* [-1] is safe because we know that bigend != big. */ return (char *) (bigend - (bigend[-1] == '\n')); s = (unsigned char *)memchr((void*)big, *little, bigend-big); if (s) return (char *)s; - if (SvTAIL(littlestr)) + if (tail) return (char *) bigend; return NULL; case 2: - if (SvTAIL(littlestr) && !multiline) { + if (tail && !multiline) { /* a littlestr with SvTAIL must be of the form "X\n" (where X * is a single char). It is anchored, and can only match * "....X\n" or "....X" */ @@ -933,7 +920,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U /* failed to find 2 chars; try anchored match at end without * the \n */ - if (SvTAIL(littlestr) && bigend[0] == little[0]) + if (tail && bigend[0] == little[0]) return (char *)bigend; return NULL; } @@ -942,7 +929,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U break; /* Only lengths 0 1 and 2 have special-case code. */ } - if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ + if (tail && !multiline) { /* tail anchored? */ s = bigend - littlelen; if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ @@ -963,7 +950,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); - if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ + if (!b && tail) { /* Automatically multiline! */ /* Chop \n from littlestr: */ s = bigend - littlelen + 1; if (*s == *little @@ -1035,7 +1022,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } check_end: if ( s == bigend - && SvTAIL(littlestr) + && tail && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; -- Perl5 Master Repository
