From 51c25d387f4c98d88a3b895660e59d0d5fe984ab Mon Sep 17 00:00:00 2001 From: "Michael G. Schwern" Date: Wed, 12 May 2021 17:02:25 -0700 Subject: [PATCH] style: Detabify the C code... again. Leftovers from 9824c081922f8e3697322536c3da1702e35e45ab and 1604cfb0273418ed479719f39def5ee559bffda2 (see #18446). These don't seem to be regressions, but never happened. Perhaps they were lost in the merge. regen_perly.pl was, again, left alone as it requires rebuilding perly.* which is beyond a simple indentation change. --- XSUB.h | 98 +- cop.h | 392 +- dquote.c | 22 +- feature.h | 126 +- lib/feature.pm | 30 +- op.c | 9262 ++++++++++++++++++------------------- perl.c | 3798 +++++++-------- perl.h | 888 ++-- pp.c | 5632 +++++++++++----------- regcomp.c | 5226 ++++++++++----------- regen/embed.pl | 6 +- regen/feature.pl | 122 +- regexec.c | 4192 ++++++++--------- regexp.h | 278 +- sv.c | 11294 ++++++++++++++++++++++----------------------- sv.h | 660 +-- toke.c | 6006 ++++++++++++------------ 17 files changed, 24016 insertions(+), 24016 deletions(-) diff --git a/XSUB.h b/XSUB.h index c1e395988542..0479ab5f2f01 100644 --- a/XSUB.h +++ b/XSUB.h @@ -160,13 +160,13 @@ is a lexical C<$_> in scope. #define dAX const I32 ax = (I32)(MARK - PL_stack_base + 1) #define dAXMARK \ - I32 ax = POPMARK; \ - SV **mark = PL_stack_base + ax++ + I32 ax = POPMARK; \ + SV **mark = PL_stack_base + ax++ #define dITEMS I32 items = (I32)(SP - MARK) #define dXSARGS \ - dSP; dAXMARK; dITEMS + dSP; dAXMARK; dITEMS /* These 3 macros are replacements for dXSARGS macro only in bootstrap. They factor out common code in every BOOT XSUB. Computation of vars mark and items will optimize away in most BOOT functions. Var ax can never be @@ -174,20 +174,20 @@ is a lexical C<$_> in scope. Note these macros are not drop in replacements for dXSARGS since they set PL_xsubfilename. */ #define dXSBOOTARGSXSAPIVERCHK \ - I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ - SV **mark = PL_stack_base + ax - 1; dSP; dITEMS + I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ + SV **mark = PL_stack_base + ax - 1; dSP; dITEMS #define dXSBOOTARGSAPIVERCHK \ - I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ - SV **mark = PL_stack_base + ax - 1; dSP; dITEMS + I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \ + SV **mark = PL_stack_base + ax - 1; dSP; dITEMS /* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do #undef dXSBOOTARGSXSAPIVERCHK #define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */ #define dXSBOOTARGSNOVERCHK \ - I32 ax = XS_SETXSUBFN_POPMARK; \ - SV **mark = PL_stack_base + ax - 1; dSP; dITEMS + I32 ax = XS_SETXSUBFN_POPMARK; \ + SV **mark = PL_stack_base + ax - 1; dSP; dITEMS #define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ - ? PAD_SV(PL_op->op_targ) : sv_newmortal()) + ? PAD_SV(PL_op->op_targ) : sv_newmortal()) /* Should be used before final PUSHi etc. if not in PPCODE section. */ #define XSprePUSH (sp = PL_stack_base + ax - 1) @@ -206,7 +206,7 @@ is a lexical C<$_> in scope. #define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION) #define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT_ANON(ret))(f)) #define XSINTERFACE_FUNC_SET(cv,f) \ - CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(f) + CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(f) #define dUNDERBAR dNOOP #define UNDERBAR find_rundefsv() @@ -323,10 +323,10 @@ Rethrows a previously caught exception. See L. #define XSRETURN(off) \ STMT_START { \ - const IV tmpXSoff = (off); \ - assert(tmpXSoff >= 0);\ - PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \ - return; \ + const IV tmpXSoff = (off); \ + assert(tmpXSoff >= 0);\ + PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \ + return; \ } STMT_END #define XSRETURN_IV(v) STMT_START { XST_mIV(0,v); XSRETURN(1); } STMT_END @@ -409,48 +409,48 @@ Rethrows a previously caught exception. See L. */ #define DBM_setFilter(db_type,code) \ - STMT_START { \ - if (db_type) \ - RETVAL = sv_mortalcopy(db_type) ; \ - ST(0) = RETVAL ; \ - if (db_type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec_NN(db_type) ; \ - db_type = NULL ; \ - } \ - else if (code) { \ - if (db_type) \ - sv_setsv(db_type, code) ; \ - else \ - db_type = newSVsv(code) ; \ - } \ - } STMT_END + STMT_START { \ + if (db_type) \ + RETVAL = sv_mortalcopy(db_type) ; \ + ST(0) = RETVAL ; \ + if (db_type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec_NN(db_type) ; \ + db_type = NULL ; \ + } \ + else if (code) { \ + if (db_type) \ + sv_setsv(db_type, code) ; \ + else \ + db_type = newSVsv(code) ; \ + } \ + } STMT_END #define DBM_ckFilter(arg,type,name) \ STMT_START { \ - if (db->type) { \ - if (db->filtering) { \ - croak("recursion detected in %s", name) ; \ - } \ - ENTER ; \ - SAVETMPS ; \ - SAVEINT(db->filtering) ; \ - db->filtering = TRUE ; \ - SAVE_DEFSV ; \ + if (db->type) { \ + if (db->filtering) { \ + croak("recursion detected in %s", name) ; \ + } \ + ENTER ; \ + SAVETMPS ; \ + SAVEINT(db->filtering) ; \ + db->filtering = TRUE ; \ + SAVE_DEFSV ; \ if (name[7] == 's') \ arg = newSVsv(arg); \ - DEFSV_set(arg) ; \ - SvTEMP_off(arg) ; \ - PUSHMARK(SP) ; \ - PUTBACK ; \ - (void) perl_call_sv(db->type, G_DISCARD); \ - SPAGAIN ; \ - PUTBACK ; \ - FREETMPS ; \ - LEAVE ; \ + DEFSV_set(arg) ; \ + SvTEMP_off(arg) ; \ + PUSHMARK(SP) ; \ + PUTBACK ; \ + (void) perl_call_sv(db->type, G_DISCARD); \ + SPAGAIN ; \ + PUTBACK ; \ + FREETMPS ; \ + LEAVE ; \ if (name[7] == 's'){ \ arg = sv_2mortal(arg); \ } \ - } } STMT_END + } } STMT_END #if 1 /* for compatibility */ # define VTBL_sv &PL_vtbl_sv diff --git a/cop.h b/cop.h index b5f30bd0415f..0c2f07950fcc 100644 --- a/cop.h +++ b/cop.h @@ -65,12 +65,12 @@ typedef struct jmpenv JMPENV; #define JMPENV_BOOTSTRAP \ STMT_START { \ - PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\ - PL_top_env = &PL_start_env; \ - PL_start_env.je_prev = NULL; \ - PL_start_env.je_ret = -1; \ - PL_start_env.je_mustcatch = TRUE; \ - PL_start_env.je_old_delaymagic = 0; \ + PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\ + PL_top_env = &PL_start_env; \ + PL_start_env.je_prev = NULL; \ + PL_start_env.je_ret = -1; \ + PL_start_env.je_mustcatch = TRUE; \ + PL_start_env.je_old_delaymagic = 0; \ JE_OLD_STACK_HWM_zero; \ } STMT_END @@ -112,57 +112,57 @@ typedef struct jmpenv JMPENV; #define JMPENV_PUSH(v) \ STMT_START { \ - DEBUG_l({ \ - int i = 0; JMPENV *p = PL_top_env; \ - while (p) { i++; p = p->je_prev; } \ - Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \ - i, __FILE__, __LINE__);}) \ - cur_env.je_prev = PL_top_env; \ + DEBUG_l({ \ + int i = 0; JMPENV *p = PL_top_env; \ + while (p) { i++; p = p->je_prev; } \ + Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \ + i, __FILE__, __LINE__);}) \ + cur_env.je_prev = PL_top_env; \ JE_OLD_STACK_HWM_save(cur_env); \ - cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \ + cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \ JE_OLD_STACK_HWM_restore(cur_env); \ - PL_top_env = &cur_env; \ - cur_env.je_mustcatch = FALSE; \ - cur_env.je_old_delaymagic = PL_delaymagic; \ - (v) = cur_env.je_ret; \ + PL_top_env = &cur_env; \ + cur_env.je_mustcatch = FALSE; \ + cur_env.je_old_delaymagic = PL_delaymagic; \ + (v) = cur_env.je_ret; \ } STMT_END #define JMPENV_POP \ STMT_START { \ - DEBUG_l({ \ - int i = -1; JMPENV *p = PL_top_env; \ - while (p) { i++; p = p->je_prev; } \ - Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \ - i, __FILE__, __LINE__);}) \ - assert(PL_top_env == &cur_env); \ - PL_delaymagic = cur_env.je_old_delaymagic; \ - PL_top_env = cur_env.je_prev; \ + DEBUG_l({ \ + int i = -1; JMPENV *p = PL_top_env; \ + while (p) { i++; p = p->je_prev; } \ + Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \ + i, __FILE__, __LINE__);}) \ + assert(PL_top_env == &cur_env); \ + PL_delaymagic = cur_env.je_old_delaymagic; \ + PL_top_env = cur_env.je_prev; \ } STMT_END #define JMPENV_JUMP(v) \ STMT_START { \ - DEBUG_l({ \ - int i = -1; JMPENV *p = PL_top_env; \ - while (p) { i++; p = p->je_prev; } \ - Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \ - (int)v, i, __FILE__, __LINE__);}) \ - if (PL_top_env->je_prev) \ - PerlProc_longjmp(PL_top_env->je_buf, (v)); \ - if ((v) == 2) \ - PerlProc_exit(STATUS_EXIT); \ - PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \ - PerlProc_exit(1); \ + DEBUG_l({ \ + int i = -1; JMPENV *p = PL_top_env; \ + while (p) { i++; p = p->je_prev; } \ + Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \ + (int)v, i, __FILE__, __LINE__);}) \ + if (PL_top_env->je_prev) \ + PerlProc_longjmp(PL_top_env->je_buf, (v)); \ + if ((v) == 2) \ + PerlProc_exit(STATUS_EXIT); \ + PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \ + PerlProc_exit(1); \ } STMT_END #define CATCH_GET (PL_top_env->je_mustcatch) #define CATCH_SET(v) \ STMT_START { \ - DEBUG_l( \ - Perl_deb(aTHX_ \ - "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \ - PL_top_env->je_mustcatch, v, (void*)PL_top_env, \ - __FILE__, __LINE__);) \ - PL_top_env->je_mustcatch = (v); \ + DEBUG_l( \ + Perl_deb(aTHX_ \ + "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \ + PL_top_env->je_mustcatch, v, (void*)PL_top_env, \ + __FILE__, __LINE__);) \ + PL_top_env->je_mustcatch = (v); \ } STMT_END /* @@ -406,7 +406,7 @@ hash of the key string, or zero if it has not been precomputed. #define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \ Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \ - (SV *)NULL, flags) + (SV *)NULL, flags) /* =for apidoc Amx|COPHH *|cophh_delete_pvs|COPHH *cophh|"key"|U32 flags @@ -419,7 +419,7 @@ of a string/length pair, and no precomputed hash. #define cophh_delete_pvs(cophh, key, flags) \ Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \ - (SV *)NULL, flags) + (SV *)NULL, flags) /* =for apidoc Amx|COPHH *|cophh_delete_pv|COPHH *cophh|char *key|U32 hash|U32 flags @@ -455,7 +455,7 @@ struct cop { /* label for this construct is now stored in cop_hints_hash */ #ifdef USE_ITHREADS PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the - package the line was compiled in */ + package the line was compiled in */ char * cop_file; /* name of file this command is from */ #else HV * cop_stash; /* package line was compiled in */ @@ -522,7 +522,7 @@ string C

, creating the package if necessary. #ifdef USE_ITHREADS # define CopFILE(c) ((c)->cop_file) # define CopFILEGV(c) (CopFILE(c) \ - ? gv_fetchfile(CopFILE(c)) : NULL) + ? gv_fetchfile(CopFILE(c)) : NULL) # ifdef NETWARE # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) @@ -533,16 +533,16 @@ string C

, creating the package if necessary. # endif # define CopFILESV(c) (CopFILE(c) \ - ? GvSV(gv_fetchfile(CopFILE(c))) : NULL) + ? GvSV(gv_fetchfile(CopFILE(c))) : NULL) # define CopFILEAV(c) (CopFILE(c) \ - ? GvAV(gv_fetchfile(CopFILE(c))) : NULL) + ? GvAV(gv_fetchfile(CopFILE(c))) : NULL) # define CopFILEAVx(c) (assert_(CopFILE(c)) \ - GvAV(gv_fetchfile(CopFILE(c)))) + GvAV(gv_fetchfile(CopFILE(c)))) # define CopSTASH(c) PL_stashpad[(c)->cop_stashoff] # define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \ - ? alloccopstash(hv) \ - : 0) + ? alloccopstash(hv) \ + : 0) # ifdef NETWARE # define CopFILE_free(c) SAVECOPFILE_FREE(c) # else @@ -561,7 +561,7 @@ string C

, creating the package if necessary. # define CopFILEAVx(c) (GvAV(CopFILEGV(c))) # endif # define CopFILE(c) (CopFILEGV(c) /* +2 for '_<' */ \ - ? GvNAME(CopFILEGV(c))+2 : NULL) + ? GvNAME(CopFILEGV(c))+2 : NULL) # define CopSTASH(c) ((c)->cop_stash) # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) # define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL)) @@ -728,8 +728,8 @@ C<*len>. Upon return, C<*flags> will be set to either C or 0. #define CopHINTS_get(c) ((c)->cop_hints + 0) #define CopHINTS_set(c, h) STMT_START { \ - (c)->cop_hints = (h); \ - } STMT_END + (c)->cop_hints = (h); \ + } STMT_END /* * Here we have some enormously heavy (or at least ponderous) wizardry. @@ -781,20 +781,20 @@ struct block_format { #endif #define CX_PUSHSUB_GET_LVALUE_MASK(func) \ - /* If the context is indeterminate, then only the lvalue */ \ - /* flags that the caller also has are applicable. */ \ - ( \ - (PL_op->op_flags & OPf_WANT) \ - ? OPpENTERSUB_LVAL_MASK \ - : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \ - ? 0 : (U8)func(aTHX) \ - ) + /* If the context is indeterminate, then only the lvalue */ \ + /* flags that the caller also has are applicable. */ \ + ( \ + (PL_op->op_flags & OPf_WANT) \ + ? OPpENTERSUB_LVAL_MASK \ + : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \ + ? 0 : (U8)func(aTHX) \ + ) /* Restore old @_ */ #define CX_POP_SAVEARRAY(cx) \ STMT_START { \ AV *cx_pop_savearray_av = GvAV(PL_defgv); \ - GvAV(PL_defgv) = cx->blk_sub.savearray; \ + GvAV(PL_defgv) = cx->blk_sub.savearray; \ cx->blk_sub.savearray = NULL; \ SvREFCNT_dec(cx_pop_savearray_av); \ } STMT_END @@ -803,9 +803,9 @@ struct block_format { * leave any (a fast av_clear(ary), basically) */ #define CLEAR_ARGARRAY(ary) \ STMT_START { \ - AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ - AvARRAY(ary) = AvALLOC(ary); \ - AvFILLp(ary) = -1; \ + AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ + AvARRAY(ary) = AvALLOC(ary); \ + AvFILLp(ary) = -1; \ } STMT_END @@ -835,27 +835,27 @@ struct block_eval { struct block_loop { LOOP * my_op; /* My op, that contains redo, next and last ops. */ union { /* different ways of locating the iteration variable */ - SV **svp; /* for lexicals: address of pad slot */ - GV *gv; /* for package vars */ + SV **svp; /* for lexicals: address of pad slot */ + GV *gv; /* for package vars */ } itervar_u; SV *itersave; /* the original iteration var */ union { - struct { /* CXt_LOOP_ARY, C */ - AV *ary; /* array being iterated over */ - IV ix; /* index relative to base of array */ - } ary; - struct { /* CXt_LOOP_LIST, C */ - I32 basesp; /* first element of list on stack */ - IV ix; /* index relative to basesp */ - } stack; - struct { /* CXt_LOOP_LAZYIV, C */ - IV cur; - IV end; - } lazyiv; - struct { /* CXt_LOOP_LAZYSV C */ - SV * cur; - SV * end; /* maxiumum value (or minimum in reverse) */ - } lazysv; + struct { /* CXt_LOOP_ARY, C */ + AV *ary; /* array being iterated over */ + IV ix; /* index relative to base of array */ + } ary; + struct { /* CXt_LOOP_LIST, C */ + I32 basesp; /* first element of list on stack */ + IV ix; /* index relative to basesp */ + } stack; + struct { /* CXt_LOOP_LAZYIV, C */ + IV cur; + IV end; + } lazyiv; + struct { /* CXt_LOOP_LAZYSV C */ + SV * cur; + SV * end; /* maxiumum value (or minimum in reverse) */ + } lazysv; } state_u; #ifdef USE_ITHREADS PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */ @@ -891,7 +891,7 @@ struct block_loop { /* given/when context */ struct block_givwhen { - OP *leave_op; + OP *leave_op; SV *defsv_save; /* the original $_ */ }; @@ -912,11 +912,11 @@ struct block { I32 blku_oldscopesp; /* scope stack index */ union { - struct block_sub blku_sub; - struct block_format blku_format; - struct block_eval blku_eval; - struct block_loop blku_loop; - struct block_givwhen blku_givwhen; + struct block_sub blku_sub; + struct block_format blku_format; + struct block_eval blku_eval; + struct block_loop blku_loop; + struct block_givwhen blku_givwhen; } blk_u; }; #define blk_oldsp cx_u.cx_blk.blku_oldsp @@ -936,15 +936,15 @@ struct block { #define CX_DEBUG(cx, action) \ DEBUG_l( \ - Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\ - (long)cxstack_ix, \ - action, \ - PL_block_type[CxTYPE(cx)], \ - (long)PL_scopestack_ix, \ - (long)(cx->blk_oldscopesp), \ - (long)PL_savestack_ix, \ - (long)(cx->blk_oldsaveix), \ - __FILE__, __LINE__)); + Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\ + (long)cxstack_ix, \ + action, \ + PL_block_type[CxTYPE(cx)], \ + (long)PL_scopestack_ix, \ + (long)(cx->blk_oldscopesp), \ + (long)PL_savestack_ix, \ + (long)(cx->blk_oldsaveix), \ + __FILE__, __LINE__)); @@ -983,32 +983,32 @@ struct subst { #define sb_rx cx_u.cx_subst.sbu_rx # define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(), \ - cx->blk_oldsaveix = oldsave, \ - cx->sb_iters = iters, \ - cx->sb_maxiters = maxiters, \ - cx->sb_rflags = r_flags, \ - cx->sb_rxtainted = rxtainted, \ - cx->sb_orig = orig, \ - cx->sb_dstr = dstr, \ - cx->sb_targ = targ, \ - cx->sb_s = s, \ - cx->sb_m = m, \ - cx->sb_strend = strend, \ - cx->sb_rxres = NULL, \ - cx->sb_rx = rx, \ - cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \ - rxres_save(&cx->sb_rxres, rx); \ - (void)ReREFCNT_inc(rx); \ + cx->blk_oldsaveix = oldsave, \ + cx->sb_iters = iters, \ + cx->sb_maxiters = maxiters, \ + cx->sb_rflags = r_flags, \ + cx->sb_rxtainted = rxtainted, \ + cx->sb_orig = orig, \ + cx->sb_dstr = dstr, \ + cx->sb_targ = targ, \ + cx->sb_s = s, \ + cx->sb_m = m, \ + cx->sb_strend = strend, \ + cx->sb_rxres = NULL, \ + cx->sb_rx = rx, \ + cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \ + rxres_save(&cx->sb_rxres, rx); \ + (void)ReREFCNT_inc(rx); \ SvREFCNT_inc_void_NN(targ) # define CX_POPSUBST(cx) \ STMT_START { \ REGEXP *re; \ assert(CxTYPE(cx) == CXt_SUBST); \ - rxres_free(&cx->sb_rxres); \ - re = cx->sb_rx; \ - cx->sb_rx = NULL; \ - ReREFCNT_dec(re); \ + rxres_free(&cx->sb_rxres); \ + re = cx->sb_rx; \ + cx->sb_rx = NULL; \ + ReREFCNT_dec(re); \ SvREFCNT_dec_NN(cx->sb_targ); \ } STMT_END #endif @@ -1017,8 +1017,8 @@ struct subst { struct context { union { - struct block cx_blk; - struct subst cx_subst; + struct block cx_blk; + struct subst cx_subst; } cx_u; }; #define cx_type cx_u.cx_subst.sbu_type @@ -1080,9 +1080,9 @@ struct context { && CxTYPE(cx) <= CXt_LOOP_PLAIN) #define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL) #define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \ - == (CXt_EVAL|CXp_REAL)) + == (CXt_EVAL|CXp_REAL)) #define CxEVALBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_EVALBLOCK)) \ - == (CXt_EVAL|CXp_EVALBLOCK)) + == (CXt_EVAL|CXp_EVALBLOCK)) #define CxTRY(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRY)) \ == (CXt_EVAL|CXp_TRY)) #define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \ @@ -1101,20 +1101,20 @@ struct context { /* extra flags for Perl_call_* routines */ #define G_DISCARD 0x4 /* Call FREETMPS. - Don't change this without consulting the - hash actions codes defined in hv.h */ + Don't change this without consulting the + hash actions codes defined in hv.h */ #define G_EVAL 0x8 /* Assume eval {} around subroutine call. */ #define G_NOARGS 0x10 /* Don't construct a @_ array. */ #define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */ #define G_NODEBUG 0x40 /* Disable debugging at toplevel. */ #define G_METHOD 0x80 /* Calling method. */ #define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or - fold_constants. */ + fold_constants. */ #define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef - A special case for UNSHIFT in - Perl_magic_methcall(). */ + A special case for UNSHIFT in + Perl_magic_methcall(). */ #define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling - Perl_magic_methcall(). */ + Perl_magic_methcall(). */ #define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */ #define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */ #define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */ @@ -1158,8 +1158,8 @@ struct stackinfo { I32 si_cxsubix; /* topmost sub/eval/format */ I32 si_type; /* type of runlevel */ I32 si_markoff; /* offset where markstack begins for us. - * currently used only with DEBUGGING, - * but not #ifdef-ed for bincompat */ + * currently used only with DEBUGGING, + * but not #ifdef-ed for bincompat */ #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY /* high water mark: for checking if the stack was correctly extended / * tested for extension by each pp function */ @@ -1195,25 +1195,25 @@ typedef struct stackinfo PERL_SI; #define PUSHSTACKi(type) \ STMT_START { \ - PERL_SI *next = PL_curstackinfo->si_next; \ - DEBUG_l({ \ - int i = 0; PERL_SI *p = PL_curstackinfo; \ - while (p) { i++; p = p->si_prev; } \ - Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \ - i, __FILE__, __LINE__);}) \ - if (!next) { \ - next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \ - next->si_prev = PL_curstackinfo; \ - PL_curstackinfo->si_next = next; \ - } \ - next->si_type = type; \ - next->si_cxix = -1; \ - next->si_cxsubix = -1; \ + PERL_SI *next = PL_curstackinfo->si_next; \ + DEBUG_l({ \ + int i = 0; PERL_SI *p = PL_curstackinfo; \ + while (p) { i++; p = p->si_prev; } \ + Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \ + i, __FILE__, __LINE__);}) \ + if (!next) { \ + next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \ + next->si_prev = PL_curstackinfo; \ + PL_curstackinfo->si_next = next; \ + } \ + next->si_type = type; \ + next->si_cxix = -1; \ + next->si_cxsubix = -1; \ PUSHSTACK_INIT_HWM(next); \ - AvFILLp(next->si_stack) = 0; \ - SWITCHSTACK(PL_curstack,next->si_stack); \ - PL_curstackinfo = next; \ - SET_MARK_OFFSET; \ + AvFILLp(next->si_stack) = 0; \ + SWITCHSTACK(PL_curstack,next->si_stack); \ + PL_curstackinfo = next; \ + SET_MARK_OFFSET; \ } STMT_END #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN) @@ -1222,27 +1222,27 @@ typedef struct stackinfo PERL_SI; * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */ #define POPSTACK \ STMT_START { \ - dSP; \ - PERL_SI * const prev = PL_curstackinfo->si_prev; \ - DEBUG_l({ \ - int i = -1; PERL_SI *p = PL_curstackinfo; \ - while (p) { i++; p = p->si_prev; } \ - Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \ - i, __FILE__, __LINE__);}) \ - if (!prev) { \ - Perl_croak_popstack(); \ - } \ - SWITCHSTACK(PL_curstack,prev->si_stack); \ - /* don't free prev here, free them all at the END{} */ \ - PL_curstackinfo = prev; \ + dSP; \ + PERL_SI * const prev = PL_curstackinfo->si_prev; \ + DEBUG_l({ \ + int i = -1; PERL_SI *p = PL_curstackinfo; \ + while (p) { i++; p = p->si_prev; } \ + Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \ + i, __FILE__, __LINE__);}) \ + if (!prev) { \ + Perl_croak_popstack(); \ + } \ + SWITCHSTACK(PL_curstack,prev->si_stack); \ + /* don't free prev here, free them all at the END{} */ \ + PL_curstackinfo = prev; \ } STMT_END #define POPSTACK_TO(s) \ STMT_START { \ - while (PL_curstack != s) { \ - dounwind(-1); \ - POPSTACK; \ - } \ + while (PL_curstack != s) { \ + dounwind(-1); \ + POPSTACK; \ + } \ } STMT_END /* @@ -1293,43 +1293,43 @@ See L. #define PUSH_MULTICALL_FLAGS(the_cv, flags) \ STMT_START { \ PERL_CONTEXT *cx; \ - CV * const _nOnclAshIngNamE_ = the_cv; \ - CV * const cv = _nOnclAshIngNamE_; \ - PADLIST * const padlist = CvPADLIST(cv); \ - multicall_oldcatch = CATCH_GET; \ - CATCH_SET(TRUE); \ - PUSHSTACKi(PERLSI_MULTICALL); \ - cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \ + CV * const _nOnclAshIngNamE_ = the_cv; \ + CV * const cv = _nOnclAshIngNamE_; \ + PADLIST * const padlist = CvPADLIST(cv); \ + multicall_oldcatch = CATCH_GET; \ + CATCH_SET(TRUE); \ + PUSHSTACKi(PERLSI_MULTICALL); \ + cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \ PL_stack_sp, PL_savestack_ix); \ cx_pushsub(cx, cv, NULL, 0); \ - SAVEOP(); \ + SAVEOP(); \ if (!(flags & CXp_SUB_RE_FAKE)) \ CvDEPTH(cv)++; \ - if (CvDEPTH(cv) >= 2) \ - Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ - PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ - multicall_cop = CvSTART(cv); \ + if (CvDEPTH(cv) >= 2) \ + Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ + multicall_cop = CvSTART(cv); \ } STMT_END #define MULTICALL \ STMT_START { \ - PL_op = multicall_cop; \ - CALLRUNOPS(aTHX); \ + PL_op = multicall_cop; \ + CALLRUNOPS(aTHX); \ } STMT_END #define POP_MULTICALL \ STMT_START { \ PERL_CONTEXT *cx; \ - cx = CX_CUR(); \ - CX_LEAVE_SCOPE(cx); \ + cx = CX_CUR(); \ + CX_LEAVE_SCOPE(cx); \ cx_popsub_common(cx); \ gimme = cx->blk_gimme; \ PERL_UNUSED_VAR(gimme); /* for API */ \ - cx_popblock(cx); \ - CX_POP(cx); \ - POPSTACK; \ - CATCH_SET(multicall_oldcatch); \ - SPAGAIN; \ + cx_popblock(cx); \ + CX_POP(cx); \ + POPSTACK; \ + CATCH_SET(multicall_oldcatch); \ + SPAGAIN; \ } STMT_END /* Change the CV of an already-pushed MULTICALL CxSUB block. @@ -1337,20 +1337,20 @@ See L. #define CHANGE_MULTICALL_FLAGS(the_cv, flags) \ STMT_START { \ - CV * const _nOnclAshIngNamE_ = the_cv; \ - CV * const cv = _nOnclAshIngNamE_; \ - PADLIST * const padlist = CvPADLIST(cv); \ + CV * const _nOnclAshIngNamE_ = the_cv; \ + CV * const cv = _nOnclAshIngNamE_; \ + PADLIST * const padlist = CvPADLIST(cv); \ PERL_CONTEXT *cx = CX_CUR(); \ - assert(CxMULTICALL(cx)); \ + assert(CxMULTICALL(cx)); \ cx_popsub_common(cx); \ - cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ + cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ cx_pushsub(cx, cv, NULL, 0); \ if (!(flags & CXp_SUB_RE_FAKE)) \ CvDEPTH(cv)++; \ - if (CvDEPTH(cv) >= 2) \ - Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ - PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ - multicall_cop = CvSTART(cv); \ + if (CvDEPTH(cv) >= 2) \ + Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ + multicall_cop = CvSTART(cv); \ } STMT_END /* * ex: set ts=8 sts=4 sw=4 et: diff --git a/dquote.c b/dquote.c index a9fa29c9ad22..e0c56228a98c 100644 --- a/dquote.c +++ b/dquote.c @@ -117,7 +117,7 @@ Perl_form_alien_digit_msg(pTHX_ /* It also isn't a UTF-8 invariant character, so no display shortcuts * are available. Use \\x{...} */ - Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad); + Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad); } /* Ready to start building the message */ @@ -288,8 +288,8 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, (*s)++; if (send <= *s || **s != '{') { - *message = "Missing braces on \\o{}"; - return FALSE; + *message = "Missing braces on \\o{}"; + return FALSE; } rbrace = (char *) memchr(*s, '}', send - *s); @@ -306,7 +306,7 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, } *message = "Missing right brace on \\o{}"; - return FALSE; + return FALSE; } /* Point to expected first digit (could be first byte of utf8 sequence if @@ -324,8 +324,8 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, numbers_len = e - *s; if (numbers_len == 0) { (*s)++; /* Move past the '}' */ - *message = "Empty \\o{}"; - return FALSE; + *message = "Empty \\o{}"; + return FALSE; } *uv = grok_oct(*s, &numbers_len, &flags, NULL); @@ -449,8 +449,8 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, if (**s != '{') { numbers_len = (strict) ? 3 : 2; - *uv = grok_hex(*s, &numbers_len, &flags, NULL); - *s += numbers_len; + *uv = grok_hex(*s, &numbers_len, &flags, NULL); + *s += numbers_len; if (numbers_len != 2 && (strict || (flags & PERL_SCAN_NOTIFY_ILLDIGIT))) { if (numbers_len == 3) { /* numbers_len 3 only happens with strict */ @@ -475,7 +475,7 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, } } } - return TRUE; + return TRUE; } rbrace = (char *) memchr(*s, '}', send - *s); @@ -491,8 +491,8 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, (*s)++; } - *message = "Missing right brace on \\x{}"; - return FALSE; + *message = "Missing right brace on \\x{}"; + return FALSE; } (*s)++; /* Point to expected first digit (could be first byte of utf8 diff --git a/feature.h b/feature.h index 501bc3a3b180..3476a37c70a8 100644 --- a/feature.h +++ b/feature.h @@ -53,132 +53,132 @@ #define FEATURE_FC_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_FC_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_FC_BIT)) \ ) #define FEATURE_ISA_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_ISA_BIT) \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_ISA_BIT) \ ) #define FEATURE_SAY_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_SAY_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_SAY_BIT)) \ ) #define FEATURE_TRY_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_TRY_BIT) \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_TRY_BIT) \ ) #define FEATURE_STATE_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_STATE_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_STATE_BIT)) \ ) #define FEATURE_SWITCH_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_SWITCH_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_SWITCH_BIT)) \ ) #define FEATURE_BITWISE_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_527 \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_527 \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_BITWISE_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_BITWISE_BIT)) \ ) #define FEATURE_INDIRECT_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_INDIRECT_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_INDIRECT_BIT)) \ ) #define FEATURE_EVALBYTES_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_EVALBYTES_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_EVALBYTES_BIT)) \ ) #define FEATURE_SIGNATURES_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_SIGNATURES_BIT) \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_SIGNATURES_BIT) \ ) #define FEATURE___SUB___IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE___SUB___BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE___SUB___BIT)) \ ) #define FEATURE_REFALIASING_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_REFALIASING_BIT) \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_REFALIASING_BIT) \ ) #define FEATURE_POSTDEREF_QQ_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_523 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_523 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_POSTDEREF_QQ_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_POSTDEREF_QQ_BIT)) \ ) #define FEATURE_UNIEVAL_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_515 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_UNIEVAL_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_UNIEVAL_BIT)) \ ) #define FEATURE_MYREF_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_MYREF_BIT) \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_MYREF_BIT) \ ) #define FEATURE_UNICODE_IS_ENABLED \ ( \ - (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_511 && \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_511 && \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527) \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_UNICODE_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_UNICODE_BIT)) \ ) #define FEATURE_MULTIDIMENSIONAL_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_MULTIDIMENSIONAL_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_MULTIDIMENSIONAL_BIT)) \ ) #define FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED \ ( \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED_MASK(FEATURE_BAREWORD_FILEHANDLES_BIT)) \ + FEATURE_IS_ENABLED_MASK(FEATURE_BAREWORD_FILEHANDLES_BIT)) \ ) @@ -203,24 +203,24 @@ S_enable_feature_bundle(pTHX_ SV *ver) { SV *comp_ver = sv_newmortal(); PL_hints = (PL_hints &~ HINT_FEATURE_MASK) - | ( - (sv_setnv(comp_ver, 5.027), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_527 : - (sv_setnv(comp_ver, 5.023), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_523 : - (sv_setnv(comp_ver, 5.015), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_515 : - (sv_setnv(comp_ver, 5.011), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_511 : - (sv_setnv(comp_ver, 5.009005), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_510 : - FEATURE_BUNDLE_DEFAULT - ) << HINT_FEATURE_SHIFT; + | ( + (sv_setnv(comp_ver, 5.027), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_527 : + (sv_setnv(comp_ver, 5.023), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_523 : + (sv_setnv(comp_ver, 5.015), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_515 : + (sv_setnv(comp_ver, 5.011), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_511 : + (sv_setnv(comp_ver, 5.009005), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_510 : + FEATURE_BUNDLE_DEFAULT + ) << HINT_FEATURE_SHIFT; /* special case */ assert(PL_curcop == &PL_compiling); if (FEATURE_UNICODE_IS_ENABLED) PL_hints |= HINT_UNI_8_BIT; diff --git a/lib/feature.pm b/lib/feature.pm index 5ebb4a3f789c..2e140ff30e5d 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -298,7 +298,7 @@ This enables unpacking of subroutine arguments into lexical variables by syntax such as sub foo ($left, $right) { - return $left + $right; + return $left + $right; } See L for details. @@ -572,8 +572,8 @@ sub unimport { # A bare C should reset to the default bundle if (!@_) { - $^H &= ~($hint_uni8bit|$hint_mask); - return; + $^H &= ~($hint_uni8bit|$hint_mask); + return; } __common(0, @_); @@ -586,14 +586,14 @@ sub __common { my $features = $bundle_number != $hint_mask && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; if ($features) { - # Features are enabled implicitly via bundle hints. - # Delete any keys that may be left over from last time. - delete @^H{ values(%feature) }; - $^H |= $hint_mask; - for (@$features) { - $^H{$feature{$_}} = 1; - $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; - } + # Features are enabled implicitly via bundle hints. + # Delete any keys that may be left over from last time. + delete @^H{ values(%feature) }; + $^H |= $hint_mask; + for (@$features) { + $^H{$feature{$_}} = 1; + $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; + } } while (@_) { my $name = shift; @@ -617,10 +617,10 @@ sub __common { } unknown_feature($name); } - if ($import) { - $^H{$feature{$name}} = 1; - $^H |= $hint_uni8bit if $name eq 'unicode_strings'; - } else { + if ($import) { + $^H{$feature{$name}} = 1; + $^H |= $hint_uni8bit if $name eq 'unicode_strings'; + } else { delete $^H{$feature{$name}}; $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; } diff --git a/op.c b/op.c index 594d4ee9c329..1a4114b9e18a 100644 --- a/op.c +++ b/op.c @@ -215,7 +215,7 @@ S_prune_chain_head(OP** op_p) /* requires double parens and aTHX_ */ #define DEBUG_S_warn(args) \ DEBUG_S( \ - PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ + PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ ) /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */ @@ -241,13 +241,13 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz) #ifdef PERL_DEBUG_READONLY_OPS slab = (OPSLAB *) mmap(0, sz_bytes, - PROT_READ|PROT_WRITE, - MAP_ANON|MAP_PRIVATE, -1, 0); + PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0); DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", - (unsigned long) sz, slab)); + (unsigned long) sz, slab)); if (slab == MAP_FAILED) { - perror("mmap failed"); - abort(); + perror("mmap failed"); + abort(); } #else slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes); @@ -330,7 +330,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) { - o = (OP*)PerlMemShared_calloc(1, sz); + o = (OP*)PerlMemShared_calloc(1, sz); goto gotit; } @@ -341,10 +341,10 @@ Perl_Slab_Alloc(pTHX_ size_t sz) allocated yet. See the commit message for 8be227ab5eaa23f2 for more details. */ if (!CvSTART(PL_compcv)) { - CvSTART(PL_compcv) = - (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE)); - CvSLABBED_on(PL_compcv); - head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + CvSTART(PL_compcv) = + (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ } else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; @@ -369,42 +369,42 @@ Perl_Slab_Alloc(pTHX_ size_t sz) DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p", (void *)o, (void *)OpMySLAB(o), (void *)head_slab)); - head_slab->opslab_freed[base_index] = o->op_next; - Zero(o, sz, char); - o->op_slabbed = 1; - goto gotit; - } + head_slab->opslab_freed[base_index] = o->op_next; + Zero(o, sz, char); + o->op_slabbed = 1; + goto gotit; + } } #define INIT_OPSLOT(s) \ - slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \ - slot->opslot_size = s; \ - slab2->opslab_free_space -= s; \ - o = &slot->opslot_op; \ - o->op_slabbed = 1 + slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \ + slot->opslot_size = s; \ + slab2->opslab_free_space -= s; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 /* The partially-filled slab is next in the chain. */ slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab; if (slab2->opslab_free_space < sz_in_p) { - /* Remaining space is too small. */ - /* If we can fit a BASEOP, add it to the free chain, so as not - to waste it. */ - if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) { - slot = &slab2->opslab_slots; - INIT_OPSLOT(slab2->opslab_free_space); - o->op_type = OP_FREED; + /* Remaining space is too small. */ + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) { + slot = &slab2->opslab_slots; + INIT_OPSLOT(slab2->opslab_free_space); + o->op_type = OP_FREED; DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p", (void *)o, (void *)slab2, (void *)head_slab)); link_freed_op(head_slab, o); - } + } - /* Create a new slab. Make this one twice as big. */ - slab2 = S_new_slab(aTHX_ head_slab, - slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2 + /* Create a new slab. Make this one twice as big. */ + slab2 = S_new_slab(aTHX_ head_slab, + slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2 ? PERL_MAX_SLAB_SIZE : slab2->opslab_size * 2); - slab2->opslab_next = head_slab->opslab_next; - head_slab->opslab_next = slab2; + slab2->opslab_next = head_slab->opslab_next; + head_slab->opslab_next = slab2; } assert(slab2->opslab_size >= sz_in_p); @@ -434,11 +434,11 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab) if (slab->opslab_readonly) return; slab->opslab_readonly = 1; for (; slab; slab = slab->opslab_next) { - /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", - (unsigned long) slab->opslab_size, (void *)slab));*/ - if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ)) - Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab, - (unsigned long)slab->opslab_size, errno); + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", + (unsigned long) slab->opslab_size, (void *)slab));*/ + if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ)) + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab, + (unsigned long)slab->opslab_size, errno); } } @@ -452,13 +452,13 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) if (!slab->opslab_readonly) return; slab2 = slab; for (; slab2; slab2 = slab2->opslab_next) { - /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", - (unsigned long) size, (void *)slab2));*/ - if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size), - PROT_READ|PROT_WRITE)) { - Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab, - (unsigned long)slab2->opslab_size, errno); - } + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", + (unsigned long) size, (void *)slab2));*/ + if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size), + PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab, + (unsigned long)slab2->opslab_size, errno); + } } slab->opslab_readonly = 0; } @@ -502,8 +502,8 @@ Perl_Slab_Free(pTHX_ void *op) if (!o->op_slabbed) { if (!o->op_static) - PerlMemShared_free(op); - return; + PerlMemShared_free(op); + return; } slab = OpSLAB(o); @@ -522,8 +522,8 @@ Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) const bool havepad = !!PL_comppad; PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { - ENTER; - PAD_SAVE_SETNULLPAD(); + ENTER; + PAD_SAVE_SETNULLPAD(); } opslab_free(slab); if (havepad) LEAVE; @@ -549,19 +549,19 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) assert(slab->opslab_refcnt == 1); PerlMemShared_free(slab->opslab_freed); do { - slab2 = slab->opslab_next; + slab2 = slab->opslab_next; #ifdef DEBUGGING - slab->opslab_refcnt = ~(size_t)0; + slab->opslab_refcnt = ~(size_t)0; #endif #ifdef PERL_DEBUG_READONLY_OPS - DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", - (void*)slab)); - if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) { - perror("munmap failed"); - abort(); - } + DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", + (void*)slab)); + if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) { + perror("munmap failed"); + abort(); + } #else - PerlMemShared_free(slab); + PerlMemShared_free(slab); #endif slab = slab2; } while (slab); @@ -583,30 +583,30 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab) do { OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space); OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size); - for (; slot < end; + for (; slot < end; slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) ) { - if (slot->opslot_op.op_type != OP_FREED - && !(slot->opslot_op.op_savefree + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree #ifdef DEBUGGING - && ++savestack_count + && ++savestack_count #endif - ) - ) { - assert(slot->opslot_op.op_slabbed); - op_free(&slot->opslot_op); - if (slab->opslab_refcnt == 1) goto free; - } - } + ) + ) { + assert(slot->opslot_op.op_slabbed); + op_free(&slot->opslot_op); + if (slab->opslab_refcnt == 1) goto free; + } + } } while ((slab2 = slab2->opslab_next)); /* > 1 because the CV still holds a reference count. */ if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ #ifdef DEBUGGING - assert(savestack_count == slab->opslab_refcnt-1); + assert(savestack_count == slab->opslab_refcnt-1); #endif - /* Remove the CV’s reference count. */ - slab->opslab_refcnt--; - return; + /* Remove the CV’s reference count. */ + slab->opslab_refcnt--; + return; } free: opslab_free(slab); @@ -655,16 +655,16 @@ Perl_op_refcnt_dec(pTHX_ OP *o) #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ - Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ - (OP*)0 ) \ + Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ + (OP*)0 ) \ : PL_check[type](aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) #define OpTYPE_set(o,type) \ STMT_START { \ - o->op_type = (OPCODE)type; \ - o->op_ppaddr = PL_ppaddr[type]; \ + o->op_type = (OPCODE)type; \ + o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END STATIC OP * @@ -673,7 +673,7 @@ S_no_fh_allowed(pTHX_ OP *o) PERL_ARGS_ASSERT_NO_FH_ALLOWED; yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", - OP_DESC(o))); + OP_DESC(o))); return o; } @@ -700,7 +700,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) PERL_ARGS_ASSERT_BAD_TYPE_PV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); + (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); } STATIC void @@ -710,7 +710,7 @@ S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)", - (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } STATIC void @@ -719,8 +719,8 @@ S_no_bareword_allowed(pTHX_ OP *o) PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; qerror(Perl_mess(aTHX_ - "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", - SVfARG(cSVOPo_sv))); + "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", + SVfARG(cSVOPo_sv))); o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ } @@ -751,8 +751,8 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PERL_ARGS_ASSERT_ALLOCMY; if (flags & ~SVf_UTF8) - Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); is_idfirst = flags & SVf_UTF8 ? isIDFIRST_utf8_safe((U8*)name + 1, name + len) @@ -767,40 +767,40 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my == KEY_sigvar ? "subroutine signature" : PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\""; - if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) - && isASCII(name[1]) - && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) { - /* diag_listed_as: Can't use global %s in %s */ - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s", - name[0], toCTRL(name[1]), + if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && isASCII(name[1]) + && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) { + /* diag_listed_as: Can't use global %s in %s */ + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, - type)); - } else { - yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s", + type)); + } else { + yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s", (int) len, name, - type), flags & SVf_UTF8); - } + type), flags & SVf_UTF8); + } } /* allocate a spare slot and store the name in that slot */ off = pad_add_name_pvn(name, len, - (is_our ? padadd_OUR : - PL_parser->in_my == KEY_state ? padadd_STATE : 0), - PL_parser->in_my_stash, - (is_our - /* $_ is always in main::, even with our */ - ? (PL_curstash && !memEQs(name,len,"$_") - ? PL_curstash - : PL_defstash) - : NULL - ) + (is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0), + PL_parser->in_my_stash, + (is_our + /* $_ is always in main::, even with our */ + ? (PL_curstash && !memEQs(name,len,"$_") + ? PL_curstash + : PL_defstash) + : NULL + ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) - CvCLONE_on(PL_compcv); + CvCLONE_on(PL_compcv); return off; } @@ -828,15 +828,15 @@ Perl_alloccopstash(pTHX_ HV *hv) if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; for (; o < PL_stashpadmax; ++o) { - if (PL_stashpad[o] == hv) return PL_stashpadix = o; - if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) - found_slot = TRUE, off = o; + if (PL_stashpad[o] == hv) return PL_stashpadix = o; + if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) + found_slot = TRUE, off = o; } if (!found_slot) { - Renew(PL_stashpad, PL_stashpadmax + 10, HV *); - Zero(PL_stashpad + PL_stashpadmax, 10, HV *); - off = PL_stashpadmax; - PL_stashpadmax += 10; + Renew(PL_stashpad, PL_stashpadmax + 10, HV *); + Zero(PL_stashpad + PL_stashpadmax, 10, HV *); + off = PL_stashpadmax; + PL_stashpadmax += 10; } PL_stashpad[PL_stashpadix = off] = hv; @@ -1049,12 +1049,12 @@ Perl_op_clear(pTHX_ OP *o) case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ case OP_ARGDEFELEM: /* Was holding signature index. */ - o->op_targ = 0; - break; + o->op_targ = 0; + break; default: - if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type)) - break; - /* FALLTHROUGH */ + if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type)) + break; + /* FALLTHROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: @@ -1063,17 +1063,17 @@ Perl_op_clear(pTHX_ OP *o) #else S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv)); #endif - break; + break; case OP_METHOD_REDIR: case OP_METHOD_REDIR_SUPER: #ifdef USE_ITHREADS - if (cMETHOPx(o)->op_rclass_targ) { - pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); - cMETHOPx(o)->op_rclass_targ = 0; - } + if (cMETHOPx(o)->op_rclass_targ) { + pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); + cMETHOPx(o)->op_rclass_targ = 0; + } #else - SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); - cMETHOPx(o)->op_rclass_sv = NULL; + SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); + cMETHOPx(o)->op_rclass_sv = NULL; #endif /* FALLTHROUGH */ case OP_METHOD_NAMED: @@ -1089,52 +1089,52 @@ Perl_op_clear(pTHX_ OP *o) break; case OP_CONST: case OP_HINTSEVAL: - SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = NULL; + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = NULL; #ifdef USE_ITHREADS - /** Bug #15654 - Even if op_clear does a pad_free for the target of the op, - pad_free doesn't actually remove the sv that exists in the pad; - instead it lives on. This results in that it could be reused as - a target later on when the pad was reallocated. - **/ + /** Bug #15654 + Even if op_clear does a pad_free for the target of the op, + pad_free doesn't actually remove the sv that exists in the pad; + instead it lives on. This results in that it could be reused as + a target later on when the pad was reallocated. + **/ if(o->op_targ) { pad_swipe(o->op_targ,1); o->op_targ = 0; } #endif - break; + break; case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: - if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) - break; - /* FALLTHROUGH */ + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; + /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: - if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) + if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) && (o->op_private & OPpTRANS_USE_SVOP)) { #ifdef USE_ITHREADS - if (cPADOPo->op_padix > 0) { - pad_swipe(cPADOPo->op_padix, TRUE); - cPADOPo->op_padix = 0; - } + if (cPADOPo->op_padix > 0) { + pad_swipe(cPADOPo->op_padix, TRUE); + cPADOPo->op_padix = 0; + } #else - SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = NULL; + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = NULL; #endif - } - else { - PerlMemShared_free(cPVOPo->op_pv); - cPVOPo->op_pv = NULL; - } - break; + } + else { + PerlMemShared_free(cPVOPo->op_pv); + cPVOPo->op_pv = NULL; + } + break; case OP_SUBST: - op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); - goto clear_pmop; + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); + goto clear_pmop; case OP_SPLIT: if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */ @@ -1149,15 +1149,15 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif } - /* FALLTHROUGH */ + /* FALLTHROUGH */ case OP_MATCH: case OP_QR: clear_pmop: - if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) - op_free(cPMOPo->op_code_list); - cPMOPo->op_code_list = NULL; - forget_pmop(cPMOPo); - cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; + if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) + op_free(cPMOPo->op_code_list); + cPMOPo->op_code_list = NULL; + forget_pmop(cPMOPo); + cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the same protection as the "SAFE" version of the PM_ macros * here since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared @@ -1165,19 +1165,19 @@ Perl_op_clear(pTHX_ OP *o) * happen before sv_clean_all */ #ifdef USE_ITHREADS - if(PL_regex_pad) { /* We could be in destruction */ - const IV offset = (cPMOPo)->op_pmoffset; - ReREFCNT_dec(PM_GETRE(cPMOPo)); - PL_regex_pad[offset] = &PL_sv_undef; + if(PL_regex_pad) { /* We could be in destruction */ + const IV offset = (cPMOPo)->op_pmoffset; + ReREFCNT_dec(PM_GETRE(cPMOPo)); + PL_regex_pad[offset] = &PL_sv_undef; sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, - sizeof(offset)); + sizeof(offset)); } #else - ReREFCNT_dec(PM_GETRE(cPMOPo)); - PM_SETRE(cPMOPo, NULL); + ReREFCNT_dec(PM_GETRE(cPMOPo)); + PM_SETRE(cPMOPo, NULL); #endif - break; + break; case OP_ARGCHECK: PerlMemShared_free(cUNOP_AUXo->op_aux); @@ -1309,8 +1309,8 @@ Perl_op_clear(pTHX_ OP *o) } if (o->op_targ > 0) { - pad_free(o->op_targ); - o->op_targ = 0; + pad_free(o->op_targ); + o->op_targ = 0; } } @@ -1321,7 +1321,7 @@ S_cop_free(pTHX_ COP* cop) CopFILE_free(cop); if (! specialWARN(cop->cop_warnings)) - PerlMemShared_free(cop->cop_warnings); + PerlMemShared_free(cop->cop_warnings); cophh_free(CopHINTHASH_get(cop)); if (PL_curcop == cop) PL_curcop = NULL; @@ -1335,31 +1335,31 @@ S_forget_pmop(pTHX_ PMOP *const o) PERL_ARGS_ASSERT_FORGET_PMOP; if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { - MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); - if (mg) { - PMOP **const array = (PMOP**) mg->mg_ptr; - U32 count = mg->mg_len / sizeof(PMOP**); - U32 i = count; - - while (i--) { - if (array[i] == o) { - /* Found it. Move the entry at the end to overwrite it. */ - array[i] = array[--count]; - mg->mg_len = count * sizeof(PMOP**); - /* Could realloc smaller at this point always, but probably - not worth it. Probably worth free()ing if we're the - last. */ - if(!count) { - Safefree(mg->mg_ptr); - mg->mg_ptr = NULL; - } - break; - } - } - } + MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP **const array = (PMOP**) mg->mg_ptr; + U32 count = mg->mg_len / sizeof(PMOP**); + U32 i = count; + + while (i--) { + if (array[i] == o) { + /* Found it. Move the entry at the end to overwrite it. */ + array[i] = array[--count]; + mg->mg_len = count * sizeof(PMOP**); + /* Could realloc smaller at this point always, but probably + not worth it. Probably worth free()ing if we're the + last. */ + if(!count) { + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + } + break; + } + } + } } if (PL_curpm == o) - PL_curpm = NULL; + PL_curpm = NULL; } @@ -1413,7 +1413,7 @@ Perl_op_null(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_NULL; if (o->op_type == OP_NULL) - return; + return; op_clear(o); o->op_targ = o->op_type; OpTYPE_set(o, OP_NULL); @@ -1675,12 +1675,12 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) { PERL_ARGS_ASSERT_OP_CONTEXTUALIZE; switch (context) { - case G_SCALAR: return scalar(o); - case G_ARRAY: return list(o); - case G_VOID: return scalarvoid(o); - default: - Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", - (long) context); + case G_SCALAR: return scalar(o); + case G_ARRAY: return list(o); + case G_VOID: return scalarvoid(o); + default: + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); } } @@ -1751,7 +1751,7 @@ S_scalarkids(pTHX_ OP *o) if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - scalar(kid); + scalar(kid); } return o; } @@ -1766,17 +1766,17 @@ S_scalarboolean(pTHX_ OP *o) (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN && cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST && !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) { - if (ckWARN(WARN_SYNTAX)) { - const line_t oldline = CopLINE(PL_curcop); + if (ckWARN(WARN_SYNTAX)) { + const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) { - /* This ensures that warnings are reported at the first line + if (PL_parser && PL_parser->copline != NOLINE) { + /* This ensures that warnings are reported at the first line of the conditional, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); + CopLINE_set(PL_curcop, PL_parser->copline); } - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); - CopLINE_set(PL_curcop, oldline); - } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); + CopLINE_set(PL_curcop, oldline); + } } return scalar(o); } @@ -1786,19 +1786,19 @@ S_op_varname_subscript(pTHX_ const OP *o, int subscript_type) { assert(o); assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || - o->op_type == OP_PADHV || o->op_type == OP_RV2HV); + o->op_type == OP_PADHV || o->op_type == OP_RV2HV); { - const char funny = o->op_type == OP_PADAV - || o->op_type == OP_RV2AV ? '@' : '%'; - if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { - GV *gv; - if (cUNOPo->op_first->op_type != OP_GV - || !(gv = cGVOPx_gv(cUNOPo->op_first))) - return NULL; - return varname(gv, funny, 0, NULL, 0, subscript_type); - } - return - varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); + const char funny = o->op_type == OP_PADAV + || o->op_type == OP_RV2AV ? '@' : '%'; + if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { + GV *gv; + if (cUNOPo->op_first->op_type != OP_GV + || !(gv = cGVOPx_gv(cUNOPo->op_first))) + return NULL; + return varname(gv, funny, 0, NULL, 0, subscript_type); + } + return + varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); } } @@ -1812,15 +1812,15 @@ static void S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) { /* or not so pretty :-) */ if (o->op_type == OP_CONST) { - *retsv = cSVOPo_sv; - if (SvPOK(*retsv)) { - SV *sv = *retsv; - *retsv = sv_newmortal(); - pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, - PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); - } - else if (!SvOK(*retsv)) - *retpv = "undef"; + *retsv = cSVOPo_sv; + if (SvPOK(*retsv)) { + SV *sv = *retsv; + *retsv = sv_newmortal(); + pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); + } + else if (!SvOK(*retsv)) + *retpv = "undef"; } else *retpv = "..."; } @@ -1830,20 +1830,20 @@ S_scalar_slice_warning(pTHX_ const OP *o) { OP *kid; const bool h = o->op_type == OP_HSLICE - || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); + || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); const char lbrack = - h ? '{' : '['; + h ? '{' : '['; const char rbrack = - h ? '}' : ']'; + h ? '}' : ']'; SV *name; SV *keysv = NULL; /* just to silence compiler warnings */ const char *key = NULL; if (!(o->op_private & OPpSLICEWARNING)) - return; + return; if (PL_parser && PL_parser->error_count) - /* This warning can be nonsensical when there is a syntax error. */ - return; + /* This warning can be nonsensical when there is a syntax error. */ + return; kid = cLISTOPo->op_first; kid = OpSIBLING(kid); /* get past pushmark */ @@ -1871,7 +1871,7 @@ S_scalar_slice_warning(pTHX_ const OP *o) case OP_LOCALTIME: case OP_GMTIME: case OP_ENTEREVAL: - return; + return; } /* Don't warn if we have a nulled list either. */ @@ -1881,24 +1881,24 @@ S_scalar_slice_warning(pTHX_ const OP *o) assert(OpSIBLING(kid)); name = S_op_varname(aTHX_ OpSIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ - return; + return; S_op_pretty(aTHX_ kid, &keysv, &key); assert(SvPOK(name)); sv_chop(name,SvPVX(name)+1); if (key) /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%" SVf "%c%s%c better written as $%" SVf - "%c%s%c", - SVfARG(name), lbrack, key, rbrack, SVfARG(name), - lbrack, key, rbrack); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Scalar value @%" SVf "%c%s%c better written as $%" SVf + "%c%s%c", + SVfARG(name), lbrack, key, rbrack, SVfARG(name), + lbrack, key, rbrack); else /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%" SVf "%c%" SVf "%c better written as $%" - SVf "%c%" SVf "%c", - SVfARG(name), lbrack, SVfARG(keysv), rbrack, - SVfARG(name), lbrack, SVfARG(keysv), rbrack); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Scalar value @%" SVf "%c%" SVf "%c better written as $%" + SVf "%c%" SVf "%c", + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); } @@ -2127,11 +2127,11 @@ Perl_scalarvoid(pTHX_ OP *arg) if (o->op_type == OP_REPEAT) scalar(cBINOPo->op_first); goto func_ops; - case OP_CONCAT: + case OP_CONCAT: if ((o->op_flags & OPf_STACKED) && - !(o->op_private & OPpCONCAT_NESTED)) + !(o->op_private & OPpCONCAT_NESTED)) break; - goto func_ops; + goto func_ops; case OP_SUBSTR: if (o->op_private == 4) break; @@ -2459,8 +2459,8 @@ S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - list(kid); + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + list(kid); } return o; } @@ -2616,29 +2616,29 @@ static OP * S_scalarseq(pTHX_ OP *o) { if (o) { - const OPCODE type = o->op_type; - - if (type == OP_LINESEQ || type == OP_SCOPE || - type == OP_LEAVE || type == OP_LEAVETRY) - { - OP *kid, *sib; - for (kid = cLISTOPo->op_first; kid; kid = sib) { - if ((sib = OpSIBLING(kid)) - && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL - || ( sib->op_targ != OP_NEXTSTATE - && sib->op_targ != OP_DBSTATE ))) - { - scalarvoid(kid); - } - } - PL_curcop = &PL_compiling; - } - o->op_flags &= ~OPf_PARENS; - if (PL_hints & HINT_BLOCK_SCOPE) - o->op_flags |= OPf_PARENS; + const OPCODE type = o->op_type; + + if (type == OP_LINESEQ || type == OP_SCOPE || + type == OP_LEAVE || type == OP_LEAVETRY) + { + OP *kid, *sib; + for (kid = cLISTOPo->op_first; kid; kid = sib) { + if ((sib = OpSIBLING(kid)) + && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL + || ( sib->op_targ != OP_NEXTSTATE + && sib->op_targ != OP_DBSTATE ))) + { + scalarvoid(kid); + } + } + PL_curcop = &PL_compiling; + } + o->op_flags &= ~OPf_PARENS; + if (PL_hints & HINT_BLOCK_SCOPE) + o->op_flags |= OPf_PARENS; } else - o = newOP(OP_STUB, 0); + o = newOP(OP_STUB, 0); return o; } @@ -2648,7 +2648,7 @@ S_modkids(pTHX_ OP *o, I32 type) if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - op_lvalue(kid, type); + op_lvalue(kid, type); } return o; } @@ -3886,16 +3886,16 @@ S_finalize_op(pTHX_ OP* o) && ckWARN(WARN_EXEC) && OpHAS_SIBLING(sib)) { - const OPCODE type = OpSIBLING(sib)->op_type; - if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { - const line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, CopLINE((COP*)sib)); - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "Statement unlikely to be reached"); - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "\t(Maybe you meant system() when you said exec()?)\n"); - CopLINE_set(PL_curcop, oldline); - } + const OPCODE type = OpSIBLING(sib)->op_type; + if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { + const line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, CopLINE((COP*)sib)); + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "Statement unlikely to be reached"); + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "\t(Maybe you meant system() when you said exec()?)\n"); + CopLINE_set(PL_curcop, oldline); + } } } break; @@ -3952,11 +3952,11 @@ S_finalize_op(pTHX_ OP* o) case OP_KVHSLICE: kid = OpSIBLING(cLISTOPo->op_first); - if (/* I bet there's always a pushmark... */ - OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) - && OP_TYPE_ISNT_NN(kid, OP_CONST)) + if (/* I bet there's always a pushmark... */ + OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) + && OP_TYPE_ISNT_NN(kid, OP_CONST)) { - break; + break; } key_op = (SVOP*)(kid->op_type == OP_CONST @@ -4045,19 +4045,19 @@ S_mark_padname_lvalue(pTHX_ PADNAME *pn) CV *cv = PL_compcv; PadnameLVALUE_on(pn); while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { - cv = CvOUTSIDE(cv); + cv = CvOUTSIDE(cv); /* RT #127786: cv can be NULL due to an eval within the DB package * called from an anon sub - anon subs don't have CvOUTSIDE() set * unless they contain an eval, but calling eval within DB * pretends the eval was done in the caller's scope. */ - if (!cv) + if (!cv) break; - assert(CvPADLIST(cv)); - pn = - PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; - assert(PadnameLEN(pn)); - PadnameLVALUE_on(pn); + assert(CvPADLIST(cv)); + pn = + PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; + assert(PadnameLEN(pn)); + PadnameLVALUE_on(pn); } } @@ -4071,7 +4071,7 @@ S_vivifies(const OPCODE type) case OP_AELEMFAST: case OP_KVHSLICE: case OP_HELEM: case OP_AELEM: - return 1; + return 1; } return 0; } @@ -4234,7 +4234,7 @@ S_potential_mod_type(I32 type) { /* Types that only potentially result in modification. */ return type == OP_GREPSTART || type == OP_ENTERSUB - || type == OP_REFGEN || type == OP_LEAVESUBLV; + || type == OP_REFGEN || type == OP_LEAVESUBLV; } @@ -4268,7 +4268,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) OP *top_op = o; if (!o || (PL_parser && PL_parser->error_count)) - return o; + return o; while (1) { OP *kid; @@ -4277,9 +4277,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) OP *next_kid = NULL; if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { - goto do_next; + goto do_next; } /* elements of a list might be in void context because the list is @@ -4291,71 +4291,71 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) switch (o->op_type) { case OP_UNDEF: - PL_modcount++; - goto do_next; + PL_modcount++; + goto do_next; case OP_STUB: - if ((o->op_flags & OPf_PARENS)) - break; - goto nomod; + if ((o->op_flags & OPf_PARENS)) + break; + goto nomod; case OP_ENTERSUB: - if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && - !(o->op_flags & OPf_STACKED)) { + if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && + !(o->op_flags & OPf_STACKED)) { OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ - assert(cUNOPo->op_first->op_type == OP_NULL); - op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ - break; - } - else { /* lvalue subroutine call */ - o->op_private |= OPpLVAL_INTRO; - PL_modcount = RETURN_UNLIMITED_NUMBER; - if (S_potential_mod_type(type)) { - o->op_private |= OPpENTERSUB_INARGS; - break; - } - else { /* Compile-time error message: */ - OP *kid = cUNOPo->op_first; - CV *cv; - GV *gv; + assert(cUNOPo->op_first->op_type == OP_NULL); + op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ + break; + } + else { /* lvalue subroutine call */ + o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (S_potential_mod_type(type)) { + o->op_private |= OPpENTERSUB_INARGS; + break; + } + else { /* Compile-time error message: */ + OP *kid = cUNOPo->op_first; + CV *cv; + GV *gv; SV *namesv; - if (kid->op_type != OP_PUSHMARK) { - if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) - Perl_croak(aTHX_ - "panic: unexpected lvalue entersub " - "args: type/targ %ld:%" UVuf, - (long)kid->op_type, (UV)kid->op_targ); - kid = kLISTOP->op_first; - } - while (OpHAS_SIBLING(kid)) - kid = OpSIBLING(kid); - if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { - break; /* Postpone until runtime */ - } - - kid = kUNOP->op_first; - if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) - kid = kUNOP->op_first; - if (kid->op_type == OP_NULL) - Perl_croak(aTHX_ - "Unexpected constant lvalue entersub " - "entry via type/targ %ld:%" UVuf, - (long)kid->op_type, (UV)kid->op_targ); - if (kid->op_type != OP_GV) { - break; - } - - gv = kGVOP_gv; - cv = isGV(gv) - ? GvCV(gv) - : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV - ? MUTABLE_CV(SvRV(gv)) - : NULL; - if (!cv) - break; - if (CvLVALUE(cv)) - break; + if (kid->op_type != OP_PUSHMARK) { + if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) + Perl_croak(aTHX_ + "panic: unexpected lvalue entersub " + "args: type/targ %ld:%" UVuf, + (long)kid->op_type, (UV)kid->op_targ); + kid = kLISTOP->op_first; + } + while (OpHAS_SIBLING(kid)) + kid = OpSIBLING(kid); + if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { + break; /* Postpone until runtime */ + } + + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL) + Perl_croak(aTHX_ + "Unexpected constant lvalue entersub " + "entry via type/targ %ld:%" UVuf, + (long)kid->op_type, (UV)kid->op_targ); + if (kid->op_type != OP_GV) { + break; + } + + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; + if (!cv) + break; + if (CvLVALUE(cv)) + break; if (flags & OP_LVALUE_NO_CROAK) return NULL; @@ -4365,21 +4365,21 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) SVfARG(namesv), PL_op_desc[type]), SvUTF8(namesv)); goto do_next; - } - } - /* FALLTHROUGH */ + } + } + /* FALLTHROUGH */ default: nomod: - if (flags & OP_LVALUE_NO_CROAK) return NULL; - /* grep, foreach, subcalls, refgen */ - if (S_potential_mod_type(type)) - break; - yyerror(Perl_form(aTHX_ "Can't modify %s in %s", - (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) - ? "do block" - : OP_DESC(o)), - type ? PL_op_desc[type] : "local")); - goto do_next; + if (flags & OP_LVALUE_NO_CROAK) return NULL; + /* grep, foreach, subcalls, refgen */ + if (S_potential_mod_type(type)) + break; + yyerror(Perl_form(aTHX_ "Can't modify %s in %s", + (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) + ? "do block" + : OP_DESC(o)), + type ? PL_op_desc[type] : "local")); + goto do_next; case OP_PREINC: case OP_PREDEC: @@ -4400,211 +4400,211 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: - if (!(o->op_flags & OPf_STACKED)) - goto nomod; - PL_modcount++; - break; + if (!(o->op_flags & OPf_STACKED)) + goto nomod; + PL_modcount++; + break; case OP_REPEAT: - if (o->op_flags & OPf_STACKED) { - PL_modcount++; - break; - } - if (!(o->op_private & OPpREPEAT_DOLIST)) - goto nomod; - else { - const I32 mods = PL_modcount; + if (o->op_flags & OPf_STACKED) { + PL_modcount++; + break; + } + if (!(o->op_private & OPpREPEAT_DOLIST)) + goto nomod; + else { + const I32 mods = PL_modcount; /* we recurse rather than iterate here because we need to * calculate and use the delta applied to PL_modcount by the * first child. So in something like * ($x, ($y) x 3) = split; * split knows that 4 elements are wanted */ - modkids(cBINOPo->op_first, type); - if (type != OP_AASSIGN) - goto nomod; - kid = cBINOPo->op_last; - if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) { - const IV iv = SvIV(kSVOP_sv); - if (PL_modcount != RETURN_UNLIMITED_NUMBER) - PL_modcount = - mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv); - } - else - PL_modcount = RETURN_UNLIMITED_NUMBER; - } - break; + modkids(cBINOPo->op_first, type); + if (type != OP_AASSIGN) + goto nomod; + kid = cBINOPo->op_last; + if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) { + const IV iv = SvIV(kSVOP_sv); + if (PL_modcount != RETURN_UNLIMITED_NUMBER) + PL_modcount = + mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv); + } + else + PL_modcount = RETURN_UNLIMITED_NUMBER; + } + break; case OP_COND_EXPR: - localize = 1; + localize = 1; next_kid = OpSIBLING(cUNOPo->op_first); - break; + break; case OP_RV2AV: case OP_RV2HV: - if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { PL_modcount = RETURN_UNLIMITED_NUMBER; /* Treat \(@foo) like ordinary list, but still mark it as modi- fiable since some contexts need to know. */ o->op_flags |= OPf_MOD; goto do_next; - } - /* FALLTHROUGH */ + } + /* FALLTHROUGH */ case OP_RV2GV: - if (scalar_mod_type(o, type)) - goto nomod; - ref(cUNOPo->op_first, o->op_type); - /* FALLTHROUGH */ + if (scalar_mod_type(o, type)) + goto nomod; + ref(cUNOPo->op_first, o->op_type); + /* FALLTHROUGH */ case OP_ASLICE: case OP_HSLICE: - localize = 1; - /* FALLTHROUGH */ + localize = 1; + /* FALLTHROUGH */ case OP_AASSIGN: - /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ - if (type == OP_LEAVESUBLV && ( - (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) - || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR - )) - o->op_private |= OPpMAYBE_LVSUB; - /* FALLTHROUGH */ + /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ + if (type == OP_LEAVESUBLV && ( + (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) + || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR + )) + o->op_private |= OPpMAYBE_LVSUB; + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; - break; + break; case OP_KVHSLICE: case OP_KVASLICE: case OP_AKEYS: - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; goto nomod; case OP_AVHVSWITCH: - if (type == OP_LEAVESUBLV - && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) - o->op_private |= OPpMAYBE_LVSUB; + if (type == OP_LEAVESUBLV + && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) + o->op_private |= OPpMAYBE_LVSUB; goto nomod; case OP_AV2ARYLEN: - PL_hints |= HINT_BLOCK_SCOPE; - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; - PL_modcount++; - break; + PL_hints |= HINT_BLOCK_SCOPE; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + PL_modcount++; + break; case OP_RV2SV: - ref(cUNOPo->op_first, o->op_type); - localize = 1; - /* FALLTHROUGH */ + ref(cUNOPo->op_first, o->op_type); + localize = 1; + /* FALLTHROUGH */ case OP_GV: - PL_hints |= HINT_BLOCK_SCOPE; + PL_hints |= HINT_BLOCK_SCOPE; /* FALLTHROUGH */ case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: - PL_modcount++; - break; + PL_modcount++; + break; case OP_AELEMFAST: case OP_AELEMFAST_LEX: - localize = -1; - PL_modcount++; - break; + localize = -1; + PL_modcount++; + break; case OP_PADAV: case OP_PADHV: PL_modcount = RETURN_UNLIMITED_NUMBER; - if (type == OP_REFGEN && o->op_flags & OPf_PARENS) - { + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) + { /* Treat \(@foo) like ordinary list, but still mark it as modi- fiable since some contexts need to know. */ - o->op_flags |= OPf_MOD; - goto do_next; - } - if (scalar_mod_type(o, type)) - goto nomod; - if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR - && type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; - /* FALLTHROUGH */ + o->op_flags |= OPf_MOD; + goto do_next; + } + if (scalar_mod_type(o, type)) + goto nomod; + if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR + && type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALLTHROUGH */ case OP_PADSV: - PL_modcount++; - if (!type) /* local() */ - Perl_croak(aTHX_ "Can't localize lexical variable %" PNf, - PNfARG(PAD_COMPNAME(o->op_targ))); - if (!(o->op_private & OPpLVAL_INTRO) - || ( type != OP_SASSIGN && type != OP_AASSIGN - && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) )) - S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ)); - break; + PL_modcount++; + if (!type) /* local() */ + Perl_croak(aTHX_ "Can't localize lexical variable %" PNf, + PNfARG(PAD_COMPNAME(o->op_targ))); + if (!(o->op_private & OPpLVAL_INTRO) + || ( type != OP_SASSIGN && type != OP_AASSIGN + && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) )) + S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ)); + break; case OP_PUSHMARK: - localize = 0; - break; + localize = 0; + break; case OP_KEYS: - if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) - goto nomod; - goto lvalue_func; + if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) + goto nomod; + goto lvalue_func; case OP_SUBSTR: - if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ - goto nomod; - /* FALLTHROUGH */ + if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ + goto nomod; + /* FALLTHROUGH */ case OP_POS: case OP_VEC: lvalue_func: - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; - if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) { + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) { /* we recurse rather than iterate here because the child * needs to be processed with a different 'type' parameter */ - /* substr and vec */ - /* If this op is in merely potential (non-fatal) modifiable - context, then apply OP_ENTERSUB context to - the kid op (to avoid croaking). Other- - wise pass this op’s own type so the correct op is mentioned - in error messages. */ - op_lvalue(OpSIBLING(cBINOPo->op_first), - S_potential_mod_type(type) - ? (I32)OP_ENTERSUB - : o->op_type); - } - break; + /* substr and vec */ + /* If this op is in merely potential (non-fatal) modifiable + context, then apply OP_ENTERSUB context to + the kid op (to avoid croaking). Other- + wise pass this op’s own type so the correct op is mentioned + in error messages. */ + op_lvalue(OpSIBLING(cBINOPo->op_first), + S_potential_mod_type(type) + ? (I32)OP_ENTERSUB + : o->op_type); + } + break; case OP_AELEM: case OP_HELEM: - ref(cBINOPo->op_first, o->op_type); - if (type == OP_ENTERSUB && - !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) - o->op_private |= OPpLVAL_DEFER; - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; - localize = 1; - PL_modcount++; - break; + ref(cBINOPo->op_first, o->op_type); + if (type == OP_ENTERSUB && + !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) + o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + localize = 1; + PL_modcount++; + break; case OP_LEAVE: case OP_LEAVELOOP: - o->op_private |= OPpLVALUE; + o->op_private |= OPpLVALUE; /* FALLTHROUGH */ case OP_SCOPE: case OP_ENTER: case OP_LINESEQ: - localize = 0; - if (o->op_flags & OPf_KIDS) - next_kid = cLISTOPo->op_last; - break; + localize = 0; + if (o->op_flags & OPf_KIDS) + next_kid = cLISTOPo->op_last; + break; case OP_NULL: - localize = 0; - if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ - goto nomod; - else if (!(o->op_flags & OPf_KIDS)) - break; + localize = 0; + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto nomod; + else if (!(o->op_flags & OPf_KIDS)) + break; - if (o->op_targ != OP_LIST) { + if (o->op_targ != OP_LIST) { OP *sib = OpSIBLING(cLISTOPo->op_first); /* OP_TRANS and OP_TRANSR with argument have a weird optree * that looks like @@ -4634,79 +4634,79 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert( !OpHAS_SIBLING(next_kid) || !OpHAS_SIBLING(OpSIBLING(next_kid))); break; - } - /* FALLTHROUGH */ + } + /* FALLTHROUGH */ case OP_LIST: - localize = 0; - next_kid = cLISTOPo->op_first; - break; + localize = 0; + next_kid = cLISTOPo->op_first; + break; case OP_COREARGS: - goto do_next; + goto do_next; case OP_AND: case OP_OR: - if (type == OP_LEAVESUBLV - || !S_vivifies(cLOGOPo->op_first->op_type)) - next_kid = cLOGOPo->op_first; - else if (type == OP_LEAVESUBLV - || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) - next_kid = OpSIBLING(cLOGOPo->op_first); - goto nomod; + if (type == OP_LEAVESUBLV + || !S_vivifies(cLOGOPo->op_first->op_type)) + next_kid = cLOGOPo->op_first; + else if (type == OP_LEAVESUBLV + || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) + next_kid = OpSIBLING(cLOGOPo->op_first); + goto nomod; case OP_SREFGEN: - if (type == OP_NULL) { /* local */ - local_refgen: - if (!FEATURE_MYREF_IS_ENABLED) - Perl_croak(aTHX_ "The experimental declared_refs " - "feature is not enabled"); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), - "Declaring references is experimental"); - next_kid = cUNOPo->op_first; - goto do_next; - } - if (type != OP_AASSIGN && type != OP_SASSIGN - && type != OP_ENTERLOOP) - goto nomod; - /* Don’t bother applying lvalue context to the ex-list. */ - kid = cUNOPx(cUNOPo->op_first)->op_first; - assert (!OpHAS_SIBLING(kid)); - goto kid_2lvref; + if (type == OP_NULL) { /* local */ + local_refgen: + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + next_kid = cUNOPo->op_first; + goto do_next; + } + if (type != OP_AASSIGN && type != OP_SASSIGN + && type != OP_ENTERLOOP) + goto nomod; + /* Don’t bother applying lvalue context to the ex-list. */ + kid = cUNOPx(cUNOPo->op_first)->op_first; + assert (!OpHAS_SIBLING(kid)); + goto kid_2lvref; case OP_REFGEN: - if (type == OP_NULL) /* local */ - goto local_refgen; - if (type != OP_AASSIGN) goto nomod; - kid = cUNOPo->op_first; + if (type == OP_NULL) /* local */ + goto local_refgen; + if (type != OP_AASSIGN) goto nomod; + kid = cUNOPo->op_first; kid_2lvref: - { - const U8 ec = PL_parser ? PL_parser->error_count : 0; - S_lvref(aTHX_ kid, type); - if (!PL_parser || PL_parser->error_count == ec) { - if (!FEATURE_REFALIASING_IS_ENABLED) - Perl_croak(aTHX_ - "Experimental aliasing via reference not enabled"); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__REFALIASING), - "Aliasing via reference is experimental"); - } - } - if (o->op_type == OP_REFGEN) - op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */ - op_null(o); - goto do_next; + { + const U8 ec = PL_parser ? PL_parser->error_count : 0; + S_lvref(aTHX_ kid, type); + if (!PL_parser || PL_parser->error_count == ec) { + if (!FEATURE_REFALIASING_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental aliasing via reference not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__REFALIASING), + "Aliasing via reference is experimental"); + } + } + if (o->op_type == OP_REFGEN) + op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */ + op_null(o); + goto do_next; case OP_SPLIT: if ((o->op_private & OPpSPLIT_ASSIGN)) { - /* This is actually @array = split. */ - PL_modcount = RETURN_UNLIMITED_NUMBER; - break; - } - goto nomod; + /* This is actually @array = split. */ + PL_modcount = RETURN_UNLIMITED_NUMBER; + break; + } + goto nomod; case OP_SCALAR: - op_lvalue(cUNOPo->op_first, OP_ENTERSUB); - goto nomod; + op_lvalue(cUNOPo->op_first, OP_ENTERSUB); + goto nomod; } /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that @@ -4719,25 +4719,25 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) - o->op_flags |= OPf_SPECIAL - |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF); + o->op_flags |= OPf_SPECIAL + |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF); else if (!type) { /* local() */ - switch (localize) { - case 1: - o->op_private |= OPpLVAL_INTRO; - o->op_flags &= ~OPf_SPECIAL; - PL_hints |= HINT_BLOCK_SCOPE; - break; - case 0: - break; - case -1: - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless localization of %s", OP_DESC(o)); - } + switch (localize) { + case 1: + o->op_private |= OPpLVAL_INTRO; + o->op_flags &= ~OPf_SPECIAL; + PL_hints |= HINT_BLOCK_SCOPE; + break; + case 0: + break; + case -1: + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless localization of %s", OP_DESC(o)); + } } else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB) - o->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; do_next: while (!next_kid) { @@ -4778,9 +4778,9 @@ S_scalar_mod_type(const OP *o, I32 type) switch (type) { case OP_POS: case OP_SASSIGN: - if (o && o->op_type == OP_RV2GV) - return FALSE; - /* FALLTHROUGH */ + if (o && o->op_type == OP_RV2GV) + return FALSE; + /* FALLTHROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: @@ -4824,9 +4824,9 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_DORASSIGN: case OP_VEC: case OP_SUBSTR: - return TRUE; + return TRUE; default: - return FALSE; + return FALSE; } } @@ -4838,20 +4838,20 @@ S_is_handle_constructor(const OP *o, I32 numargs) switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: - if (numargs == 2) - return TRUE; - /* FALLTHROUGH */ + if (numargs == 2) + return TRUE; + /* FALLTHROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: - if (numargs == 1) - return TRUE; - /* FALLTHROUGH */ + if (numargs == 1) + return TRUE; + /* FALLTHROUGH */ default: - return FALSE; + return FALSE; } } @@ -4861,7 +4861,7 @@ S_refkids(pTHX_ OP *o, I32 type) if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - ref(kid, type); + ref(kid, type); } return o; } @@ -4887,7 +4887,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) PERL_ARGS_ASSERT_DOREF; if (PL_parser && PL_parser->error_count) - return o; + return o; while (1) { switch (o->op_type) { @@ -5014,16 +5014,16 @@ S_dup_attrlist(pTHX_ OP *o) * are OP_CONST. We need to push the OP_CONST values. */ if (o->op_type == OP_CONST) - rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); + rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); else { - assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); - rop = NULL; - for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) { - if (o->op_type == OP_CONST) - rop = op_append_elem(OP_LIST, rop, - newSVOP(OP_CONST, o->op_flags, - SvREFCNT_inc_NN(cSVOPo->op_sv))); - } + assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); + rop = NULL; + for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) { + if (o->op_type == OP_CONST) + rop = op_append_elem(OP_LIST, rop, + newSVOP(OP_CONST, o->op_flags, + SvREFCNT_inc_NN(cSVOPo->op_sv))); + } } return rop; } @@ -5062,20 +5062,20 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) PERL_ARGS_ASSERT_APPLY_ATTRS_MY; if (!attrs) - return; + return; assert(target->op_type == OP_PADSV || - target->op_type == OP_PADHV || - target->op_type == OP_PADAV); + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ /* Don't force the C if we don't need it. */ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) - NOOP; /* already in %INC */ + NOOP; /* already in %INC */ else - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs(ATTRSMODULE), NULL); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs(ATTRSMODULE), NULL); /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); @@ -5086,18 +5086,18 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; arg = op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - op_prepend_elem(OP_LIST, - newUNOP(OP_REFGEN, 0, - arg), - dup_attrlist(attrs))); + newSVOP(OP_CONST, 0, stashsv), + op_prepend_elem(OP_LIST, + newUNOP(OP_REFGEN, 0, + arg), + dup_attrlist(attrs))); /* Fake up a method call to import */ meth = newSVpvs_share("import"); imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, - op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, pack, arg), - newMETHOP_named(OP_METHOD_NAMED, 0, meth))); + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); /* Combine the ops. */ *imopsp = op_append_elem(OP_LIST, *imopsp, imop); @@ -5144,12 +5144,12 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, } Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvs(ATTRSMODULE), + newSVpvs(ATTRSMODULE), NULL, op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), - op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(MUTABLE_SV(cv))), + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(MUTABLE_SV(cv))), attrs))); } @@ -5281,72 +5281,72 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) PERL_ARGS_ASSERT_MY_KID; if (!o || (PL_parser && PL_parser->error_count)) - return o; + return o; type = o->op_type; if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - my_kid(kid, attrs, imopsp); - return o; + my_kid(kid, attrs, imopsp); + return o; } else if (type == OP_UNDEF || type == OP_STUB) { - return o; + return o; } else if (type == OP_RV2SV || /* "our" declaration */ - type == OP_RV2AV || - type == OP_RV2HV) { - if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - S_cant_declare(aTHX_ o); - } else if (attrs) { - GV * const gv = cGVOPx_gv(cUNOPo->op_first); - assert(PL_parser); - PL_parser->in_my = FALSE; - PL_parser->in_my_stash = NULL; - apply_attrs(GvSTASH(gv), - (type == OP_RV2SV ? GvSVn(gv) : - type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) : - type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)), - attrs); - } - o->op_private |= OPpOUR_INTRO; - return o; + type == OP_RV2AV || + type == OP_RV2HV) { + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + S_cant_declare(aTHX_ o); + } else if (attrs) { + GV * const gv = cGVOPx_gv(cUNOPo->op_first); + assert(PL_parser); + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; + apply_attrs(GvSTASH(gv), + (type == OP_RV2SV ? GvSVn(gv) : + type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) : + type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)), + attrs); + } + o->op_private |= OPpOUR_INTRO; + return o; } else if (type == OP_REFGEN || type == OP_SREFGEN) { - if (!FEATURE_MYREF_IS_ENABLED) - Perl_croak(aTHX_ "The experimental declared_refs " - "feature is not enabled"); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), - "Declaring references is experimental"); - /* Kid is a nulled OP_LIST, handled above. */ - my_kid(cUNOPo->op_first, attrs, imopsp); - return o; + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + /* Kid is a nulled OP_LIST, handled above. */ + my_kid(cUNOPo->op_first, attrs, imopsp); + return o; } else if (type != OP_PADSV && - type != OP_PADAV && - type != OP_PADHV && - type != OP_PUSHMARK) + type != OP_PADAV && + type != OP_PADHV && + type != OP_PUSHMARK) { - S_cant_declare(aTHX_ o); - return o; + S_cant_declare(aTHX_ o); + return o; } else if (attrs && type != OP_PUSHMARK) { - HV *stash; + HV *stash; assert(PL_parser); - PL_parser->in_my = FALSE; - PL_parser->in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; - /* check for C when deciding package */ - stash = PAD_COMPNAME_TYPE(o->op_targ); - if (!stash) - stash = PL_curstash; - apply_attrs_my(stash, o, attrs, imopsp); + /* check for C when deciding package */ + stash = PAD_COMPNAME_TYPE(o->op_targ); + if (!stash) + stash = PL_curstash; + apply_attrs_my(stash, o, attrs, imopsp); } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; if (stately) - o->op_private |= OPpPAD_STATE; + o->op_private |= OPpPAD_STATE; return o; } @@ -5362,35 +5362,35 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) - list(o); + list(o); else - maybe_scalar = 1; + maybe_scalar = 1; #else maybe_scalar = 1; #endif if (attrs) - SAVEFREEOP(attrs); + SAVEFREEOP(attrs); rops = NULL; o = my_kid(o, attrs, &rops); if (rops) { - if (maybe_scalar && o->op_type == OP_PADSV) { - o = scalar(op_append_list(OP_LIST, rops, o)); - o->op_private |= OPpLVAL_INTRO; - } - else { - /* The listop in rops might have a pushmark at the beginning, - which will mess up list assignment. */ - LISTOP * const lrops = (LISTOP *)rops; /* for brevity */ - if (rops->op_type == OP_LIST && - lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) - { - OP * const pushmark = lrops->op_first; + if (maybe_scalar && o->op_type == OP_PADSV) { + o = scalar(op_append_list(OP_LIST, rops, o)); + o->op_private |= OPpLVAL_INTRO; + } + else { + /* The listop in rops might have a pushmark at the beginning, + which will mess up list assignment. */ + LISTOP * const lrops = (LISTOP *)rops; /* for brevity */ + if (rops->op_type == OP_LIST && + lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) + { + OP * const pushmark = lrops->op_first; /* excise pushmark */ op_sibling_splice(rops, NULL, 1, NULL); - op_free(pushmark); - } - o = op_append_list(OP_LIST, o, rops); - } + op_free(pushmark); + } + o = op_append_list(OP_LIST, o, rops); + } } PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -5402,7 +5402,7 @@ Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; if (o) - o->op_flags |= OPf_PARENS; + o->op_flags |= OPf_PARENS; return o; } @@ -5417,53 +5417,53 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) PERL_ARGS_ASSERT_BIND_MATCH; if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV - || ltype == OP_PADHV) && ckWARN(WARN_MISC)) + || ltype == OP_PADHV) && ckWARN(WARN_MISC)) { const char * const desc - = PL_op_desc[( - rtype == OP_SUBST || rtype == OP_TRANS - || rtype == OP_TRANSR - ) - ? (int)rtype : OP_MATCH]; + = PL_op_desc[( + rtype == OP_SUBST || rtype == OP_TRANS + || rtype == OP_TRANSR + ) + ? (int)rtype : OP_MATCH]; const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; SV * const name = - S_op_varname(aTHX_ left); + S_op_varname(aTHX_ left); if (name) - Perl_warner(aTHX_ packWARN(WARN_MISC), + Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %" SVf " will act on scalar(%" SVf ")", desc, SVfARG(name), SVfARG(name)); else { - const char * const sample = (isary - ? "@array" : "%hash"); - Perl_warner(aTHX_ packWARN(WARN_MISC), + const char * const sample = (isary + ? "@array" : "%hash"); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } } if (rtype == OP_CONST && - cSVOPx(right)->op_private & OPpCONST_BARE && - cSVOPx(right)->op_private & OPpCONST_STRICT) + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) { - no_bareword_allowed(right); + no_bareword_allowed(right); } /* !~ doesn't make sense with /r, so error on it for now */ if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && - type == OP_NOT) - /* diag_listed_as: Using !~ with %s doesn't make sense */ - yyerror("Using !~ with s///r doesn't make sense"); + type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ + yyerror("Using !~ with s///r doesn't make sense"); if (rtype == OP_TRANSR && type == OP_NOT) - /* diag_listed_as: Using !~ with %s doesn't make sense */ - yyerror("Using !~ with tr///r doesn't make sense"); + /* diag_listed_as: Using !~ with %s doesn't make sense */ + yyerror("Using !~ with tr///r doesn't make sense"); ismatchop = (rtype == OP_MATCH || - rtype == OP_SUBST || - rtype == OP_TRANS || rtype == OP_TRANSR) - && !(right->op_flags & OPf_SPECIAL); + rtype == OP_SUBST || + rtype == OP_TRANS || rtype == OP_TRANSR) + && !(right->op_flags & OPf_SPECIAL); if (ismatchop && right->op_private & OPpTARGET_MY) { - right->op_targ = 0; - right->op_private &= ~OPpTARGET_MY; + right->op_targ = 0; + right->op_private &= ~OPpTARGET_MY; } if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) { if (left->op_type == OP_PADSV @@ -5478,28 +5478,28 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) if (rtype != OP_MATCH && rtype != OP_TRANSR && ! (rtype == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL) && - ! (rtype == OP_SUBST && - (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) - left = op_lvalue(left, rtype); - if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) - o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); - else - o = op_prepend_elem(rtype, scalar(left), right); - } - if (type == OP_NOT) - return newUNOP(OP_NOT, 0, scalar(o)); - return o; + ! (rtype == OP_SUBST && + (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) + left = op_lvalue(left, rtype); + if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) + o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); + else + o = op_prepend_elem(rtype, scalar(left), right); + } + if (type == OP_NOT) + return newUNOP(OP_NOT, 0, scalar(o)); + return o; } else - return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0)); + return bind_match(type, left, + pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0)); } OP * Perl_invert(pTHX_ OP *o) { if (!o) - return NULL; + return NULL; return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } @@ -5510,9 +5510,9 @@ Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right) OP *op; if (!left) - left = newOP(OP_NULL, 0); + left = newOP(OP_NULL, 0); if (!right) - right = newOP(OP_NULL, 0); + right = newOP(OP_NULL, 0); scalar(left); scalar(right); NewOp(0, bop, 1, BINOP); @@ -5536,30 +5536,30 @@ Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right) PERL_ARGS_ASSERT_CMPCHAIN_EXTEND; if (!right) - right = newOP(OP_NULL, 0); + right = newOP(OP_NULL, 0); scalar(right); NewOp(0, bop, 1, BINOP); op = (OP*)bop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP); OpTYPE_set(op, type); if (ch->op_type != OP_NULL) { - UNOP *lch; - OP *nch, *cleft, *cright; - NewOp(0, lch, 1, UNOP); - nch = (OP*)lch; - OpTYPE_set(nch, OP_NULL); - nch->op_flags = OPf_KIDS; - cleft = cBINOPx(ch)->op_first; - cright = cBINOPx(ch)->op_last; - cBINOPx(ch)->op_first = NULL; - cBINOPx(ch)->op_last = NULL; - cBINOPx(ch)->op_private = 0; - cBINOPx(ch)->op_flags = 0; - cUNOPx(nch)->op_first = cright; - OpMORESIB_set(cright, ch); - OpMORESIB_set(ch, cleft); - OpLASTSIB_set(cleft, nch); - ch = nch; + UNOP *lch; + OP *nch, *cleft, *cright; + NewOp(0, lch, 1, UNOP); + nch = (OP*)lch; + OpTYPE_set(nch, OP_NULL); + nch->op_flags = OPf_KIDS; + cleft = cBINOPx(ch)->op_first; + cright = cBINOPx(ch)->op_last; + cBINOPx(ch)->op_first = NULL; + cBINOPx(ch)->op_last = NULL; + cBINOPx(ch)->op_private = 0; + cBINOPx(ch)->op_flags = 0; + cUNOPx(nch)->op_first = cright; + OpMORESIB_set(cright, ch); + OpMORESIB_set(ch, cleft); + OpLASTSIB_set(cleft, nch); + ch = nch; } OpMORESIB_set(right, op); OpMORESIB_set(op, cUNOPx(ch)->op_first); @@ -5573,48 +5573,48 @@ Perl_cmpchain_finish(pTHX_ OP *ch) PERL_ARGS_ASSERT_CMPCHAIN_FINISH; if (ch->op_type != OP_NULL) { - OPCODE cmpoptype = ch->op_type; - ch = CHECKOP(cmpoptype, ch); - if(!ch->op_next && ch->op_type == cmpoptype) - ch = fold_constants(op_integerize(op_std_init(ch))); - return ch; + OPCODE cmpoptype = ch->op_type; + ch = CHECKOP(cmpoptype, ch); + if(!ch->op_next && ch->op_type == cmpoptype) + ch = fold_constants(op_integerize(op_std_init(ch))); + return ch; } else { - OP *condop = NULL; - OP *rightarg = cUNOPx(ch)->op_first; - cUNOPx(ch)->op_first = OpSIBLING(rightarg); - OpLASTSIB_set(rightarg, NULL); - while (1) { - OP *cmpop = cUNOPx(ch)->op_first; - OP *leftarg = OpSIBLING(cmpop); - OPCODE cmpoptype = cmpop->op_type; - OP *nextrightarg; - bool is_last; - is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg)); - OpLASTSIB_set(cmpop, NULL); - OpLASTSIB_set(leftarg, NULL); - if (is_last) { - ch->op_flags = 0; - op_free(ch); - nextrightarg = NULL; - } else { - nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg); - leftarg = newOP(OP_NULL, 0); - } - cBINOPx(cmpop)->op_first = leftarg; - cBINOPx(cmpop)->op_last = rightarg; - OpMORESIB_set(leftarg, rightarg); - OpLASTSIB_set(rightarg, cmpop); - cmpop->op_flags = OPf_KIDS; - cmpop->op_private = 2; - cmpop = CHECKOP(cmpoptype, cmpop); - if(!cmpop->op_next && cmpop->op_type == cmpoptype) - cmpop = op_integerize(op_std_init(cmpop)); - condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : - cmpop; - if (!nextrightarg) - return condop; - rightarg = nextrightarg; - } + OP *condop = NULL; + OP *rightarg = cUNOPx(ch)->op_first; + cUNOPx(ch)->op_first = OpSIBLING(rightarg); + OpLASTSIB_set(rightarg, NULL); + while (1) { + OP *cmpop = cUNOPx(ch)->op_first; + OP *leftarg = OpSIBLING(cmpop); + OPCODE cmpoptype = cmpop->op_type; + OP *nextrightarg; + bool is_last; + is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg)); + OpLASTSIB_set(cmpop, NULL); + OpLASTSIB_set(leftarg, NULL); + if (is_last) { + ch->op_flags = 0; + op_free(ch); + nextrightarg = NULL; + } else { + nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg); + leftarg = newOP(OP_NULL, 0); + } + cBINOPx(cmpop)->op_first = leftarg; + cBINOPx(cmpop)->op_last = rightarg; + OpMORESIB_set(leftarg, rightarg); + OpLASTSIB_set(rightarg, cmpop); + cmpop->op_flags = OPf_KIDS; + cmpop->op_private = 2; + cmpop = CHECKOP(cmpoptype, cmpop); + if(!cmpop->op_next && cmpop->op_type == cmpoptype) + cmpop = op_integerize(op_std_init(cmpop)); + condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : + cmpop; + if (!nextrightarg) + return condop; + rightarg = nextrightarg; + } } } @@ -5636,27 +5636,27 @@ OP * Perl_op_scope(pTHX_ OP *o) { if (o) { - if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { - o = op_prepend_elem(OP_LINESEQ, + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o); OpTYPE_set(o, OP_LEAVE); - } - else if (o->op_type == OP_LINESEQ) { - OP *kid; + } + else if (o->op_type == OP_LINESEQ) { + OP *kid; OpTYPE_set(o, OP_SCOPE); - kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { - op_null(kid); - - /* The following deals with things like 'do {1 for 1}' */ - kid = OpSIBLING(kid); - if (kid && - (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) - op_null(kid); - } - } - else - o = newLISTOP(OP_SCOPE, 0, o, NULL); + kid = ((LISTOP*)o)->op_first; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + op_null(kid); + + /* The following deals with things like 'do {1 for 1}' */ + kid = OpSIBLING(kid); + if (kid && + (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) + op_null(kid); + } + } + else + o = newLISTOP(OP_SCOPE, 0, o, NULL); } return o; } @@ -5665,10 +5665,10 @@ OP * Perl_op_unscope(pTHX_ OP *o) { if (o && o->op_type == OP_LINESEQ) { - OP *kid = cLISTOPo->op_first; - for(; kid; kid = OpSIBLING(kid)) - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - op_null(kid); + OP *kid = cLISTOPo->op_first; + for(; kid; kid = OpSIBLING(kid)) + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + op_null(kid); } return o; } @@ -5725,75 +5725,75 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) /* XXX Is the null PL_parser check necessary here? */ assert(PL_parser); /* Let’s find out under debugging builds. */ if (PL_parser && PL_parser->parsed_sub) { - o = newSTATEOP(0, NULL, NULL); - op_null(o); - retval = op_append_elem(OP_LINESEQ, retval, o); + o = newSTATEOP(0, NULL, NULL); + op_null(o); + retval = op_append_elem(OP_LINESEQ, retval, o); } CALL_BLOCK_HOOKS(bhk_pre_end, &retval); LEAVE_SCOPE(floor); if (needblockscope) - PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ + PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ o = pad_leavemy(); if (o) { - /* pad_leavemy has created a sequence of introcv ops for all my - subs declared in the block. We have to replicate that list with - clonecv ops, to deal with this situation: - - sub { - my sub s1; - my sub s2; - sub s1 { state sub foo { \&s2 } } - }->() - - Originally, I was going to have introcv clone the CV and turn - off the stale flag. Since &s1 is declared before &s2, the - introcv op for &s1 is executed (on sub entry) before the one for - &s2. But the &foo sub inside &s1 (which is cloned when &s1 is - cloned, since it is a state sub) closes over &s2 and expects - to see it in its outer CV’s pad. If the introcv op clones &s1, - then &s2 is still marked stale. Since &s1 is not active, and - &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia- - ble will not stay shared’ warning. Because it is the same stub - that will be used when the introcv op for &s2 is executed, clos- - ing over it is safe. Hence, we have to turn off the stale flag - on all lexical subs in the block before we clone any of them. - Hence, having introcv clone the sub cannot work. So we create a - list of ops like this: - - lineseq - | - +-- introcv - | - +-- introcv - | - +-- introcv - | - . - . - . - | - +-- clonecv - | - +-- clonecv - | - +-- clonecv - | - . - . - . - */ - OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; - OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; - for (;; kid = OpSIBLING(kid)) { - OP *newkid = newOP(OP_CLONECV, 0); - newkid->op_targ = kid->op_targ; - o = op_append_elem(OP_LINESEQ, o, newkid); - if (kid == last) break; - } - retval = op_prepend_elem(OP_LINESEQ, o, retval); + /* pad_leavemy has created a sequence of introcv ops for all my + subs declared in the block. We have to replicate that list with + clonecv ops, to deal with this situation: + + sub { + my sub s1; + my sub s2; + sub s1 { state sub foo { \&s2 } } + }->() + + Originally, I was going to have introcv clone the CV and turn + off the stale flag. Since &s1 is declared before &s2, the + introcv op for &s1 is executed (on sub entry) before the one for + &s2. But the &foo sub inside &s1 (which is cloned when &s1 is + cloned, since it is a state sub) closes over &s2 and expects + to see it in its outer CV’s pad. If the introcv op clones &s1, + then &s2 is still marked stale. Since &s1 is not active, and + &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia- + ble will not stay shared’ warning. Because it is the same stub + that will be used when the introcv op for &s2 is executed, clos- + ing over it is safe. Hence, we have to turn off the stale flag + on all lexical subs in the block before we clone any of them. + Hence, having introcv clone the sub cannot work. So we create a + list of ops like this: + + lineseq + | + +-- introcv + | + +-- introcv + | + +-- introcv + | + . + . + . + | + +-- clonecv + | + +-- clonecv + | + +-- clonecv + | + . + . + . + */ + OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; + OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; + for (;; kid = OpSIBLING(kid)) { + OP *newkid = newOP(OP_CLONECV, 0); + newkid->op_targ = kid->op_targ; + o = op_append_elem(OP_LINESEQ, o, newkid); + if (kid == last) break; + } + retval = op_prepend_elem(OP_LINESEQ, o, retval); } CALL_BLOCK_HOOKS(bhk_post_end, &retval); @@ -5828,35 +5828,35 @@ Perl_newPROG(pTHX_ OP *o) PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { - PERL_CONTEXT *cx; - I32 i; - if (PL_eval_root) - return; - PL_eval_root = newUNOP(OP_LEAVEEVAL, - ((PL_in_eval & EVAL_KEEPERR) - ? OPf_SPECIAL : 0), o); - - cx = CX_CUR(); - assert(CxTYPE(cx) == CXt_EVAL); - - if ((cx->blk_gimme & G_WANT) == G_VOID) - scalarvoid(PL_eval_root); - else if ((cx->blk_gimme & G_WANT) == G_ARRAY) - list(PL_eval_root); - else - scalar(PL_eval_root); + PERL_CONTEXT *cx; + I32 i; + if (PL_eval_root) + return; + PL_eval_root = newUNOP(OP_LEAVEEVAL, + ((PL_in_eval & EVAL_KEEPERR) + ? OPf_SPECIAL : 0), o); + + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + + if ((cx->blk_gimme & G_WANT) == G_VOID) + scalarvoid(PL_eval_root); + else if ((cx->blk_gimme & G_WANT) == G_ARRAY) + list(PL_eval_root); + else + scalar(PL_eval_root); start = op_linklist(PL_eval_root); - PL_eval_root->op_next = 0; - i = PL_savestack_ix; - SAVEFREEOP(o); - ENTER; + PL_eval_root->op_next = 0; + i = PL_savestack_ix; + SAVEFREEOP(o); + ENTER; S_process_optree(aTHX_ NULL, PL_eval_root, start); - LEAVE; - PL_savestack_ix = i; + LEAVE; + PL_savestack_ix = i; } else { - if (o->op_type == OP_STUB) { + if (o->op_type == OP_STUB) { /* This block is entered if nothing is compiled for the main program. This will be the case for an genuinely empty main program, or one which only has BEGIN blocks etc, so already @@ -5883,33 +5883,33 @@ Perl_newPROG(pTHX_ OP *o) promptly, and the exit code will remain 0. */ - PL_comppad_name = 0; - PL_compcv = 0; - S_op_destroy(aTHX_ o); - return; - } - PL_main_root = op_scope(sawparens(scalarvoid(o))); - PL_curcop = &PL_compiling; + PL_comppad_name = 0; + PL_compcv = 0; + S_op_destroy(aTHX_ o); + return; + } + PL_main_root = op_scope(sawparens(scalarvoid(o))); + PL_curcop = &PL_compiling; start = LINKLIST(PL_main_root); - PL_main_root->op_next = 0; + PL_main_root->op_next = 0; S_process_optree(aTHX_ NULL, PL_main_root, start); if (!PL_parser->error_count) /* on error, leave CV slabbed so that ops left lying around * will eb cleaned up. Else unslab */ cv_forget_slab(PL_compcv); - PL_compcv = 0; - - /* Register with debugger */ - if (PERLDB_INTER) { - CV * const cv = get_cvs("DB::postponed", 0); - if (cv) { - dSP; - PUSHMARK(SP); - XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); - PUTBACK; - call_sv(MUTABLE_SV(cv), G_DISCARD); - } - } + PL_compcv = 0; + + /* Register with debugger */ + if (PERLDB_INTER) { + CV * const cv = get_cvs("DB::postponed", 0); + if (cv) { + dSP; + PUSHMARK(SP); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); + PUTBACK; + call_sv(MUTABLE_SV(cv), G_DISCARD); + } + } } } @@ -5922,53 +5922,53 @@ Perl_localize(pTHX_ OP *o, I32 lex) /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 - list(o); + list(o); #else - NOOP; + NOOP; #endif else { - if ( PL_parser->bufptr > PL_parser->oldbufptr - && PL_parser->bufptr[-1] == ',' - && ckWARN(WARN_PARENTHESIS)) - { - char *s = PL_parser->bufptr; - bool sigil = FALSE; - - /* some heuristics to detect a potential error */ - while (*s && (memCHRs(", \t\n", *s))) - s++; - - while (1) { - if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*')) - && *++s - && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { - s++; - sigil = TRUE; - while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) - s++; - while (*s && (memCHRs(", \t\n", *s))) - s++; - } - else - break; - } - if (sigil && (*s == ';' || *s == '=')) { - Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), - "Parentheses missing around \"%s\" list", - lex - ? (PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state - ? "state" - : "my") - : "local"); - } - } + if ( PL_parser->bufptr > PL_parser->oldbufptr + && PL_parser->bufptr[-1] == ',' + && ckWARN(WARN_PARENTHESIS)) + { + char *s = PL_parser->bufptr; + bool sigil = FALSE; + + /* some heuristics to detect a potential error */ + while (*s && (memCHRs(", \t\n", *s))) + s++; + + while (1) { + if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*')) + && *++s + && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { + s++; + sigil = TRUE; + while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) + s++; + while (*s && (memCHRs(", \t\n", *s))) + s++; + } + else + break; + } + if (sigil && (*s == ';' || *s == '=')) { + Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), + "Parentheses missing around \"%s\" list", + lex + ? (PL_parser->in_my == KEY_our + ? "our" + : PL_parser->in_my == KEY_state + ? "state" + : "my") + : "local"); + } + } } if (lex) - o = my(o); + o = my(o); else - o = op_lvalue(o, OP_NULL); /* a bit kludgey */ + o = op_lvalue(o, OP_NULL); /* a bit kludgey */ PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; return o; @@ -6003,9 +6003,9 @@ S_op_std_init(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_STD_INIT; if (PL_opargs[type] & OA_RETSCALAR) - scalar(o); + scalar(o); if (PL_opargs[type] & OA_TARGET && !o->op_targ) - o->op_targ = pad_alloc(type, SVs_PADTMP); + o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } @@ -6020,12 +6020,12 @@ S_op_integerize(pTHX_ OP *o) /* integerize op. */ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) { - o->op_ppaddr = PL_ppaddr[++(o->op_type)]; + o->op_ppaddr = PL_ppaddr[++(o->op_type)]; } if (type == OP_NEGATE) - /* XXX might want a ck_negate() for this */ - cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; + /* XXX might want a ck_negate() for this */ + cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; return o; } @@ -6042,7 +6042,7 @@ S_fold_constants_eval(pTHX) { JMPENV_PUSH(ret); if (ret == 0) { - CALLRUNOPS(aTHX); + CALLRUNOPS(aTHX); } JMPENV_POP; @@ -6069,7 +6069,7 @@ S_fold_constants(pTHX_ OP *const o) PERL_ARGS_ASSERT_FOLD_CONSTANTS; if (!(PL_opargs[type] & OA_FOLDCONST)) - goto nope; + goto nope; switch (type) { case OP_UCFIRST: @@ -6078,8 +6078,8 @@ S_fold_constants(pTHX_ OP *const o) case OP_LC: case OP_FC: #ifdef USE_LOCALE_CTYPE - if (IN_LC_COMPILETIME(LC_CTYPE)) - goto nope; + if (IN_LC_COMPILETIME(LC_CTYPE)) + goto nope; #endif break; case OP_SLT: @@ -6088,44 +6088,44 @@ S_fold_constants(pTHX_ OP *const o) case OP_SGE: case OP_SCMP: #ifdef USE_LOCALE_COLLATE - if (IN_LC_COMPILETIME(LC_COLLATE)) - goto nope; + if (IN_LC_COMPILETIME(LC_COLLATE)) + goto nope; #endif break; case OP_SPRINTF: - /* XXX what about the numeric ops? */ + /* XXX what about the numeric ops? */ #ifdef USE_LOCALE_NUMERIC - if (IN_LC_COMPILETIME(LC_NUMERIC)) - goto nope; + if (IN_LC_COMPILETIME(LC_NUMERIC)) + goto nope; #endif - break; + break; case OP_PACK: - if (!OpHAS_SIBLING(cLISTOPo->op_first) - || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST) - goto nope; - { - SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first)); - if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; - { - const char *s = SvPVX_const(sv); - while (s < SvEND(sv)) { - if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; - s++; - } - } - } - break; + if (!OpHAS_SIBLING(cLISTOPo->op_first) + || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST) + goto nope; + { + SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first)); + if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; + { + const char *s = SvPVX_const(sv); + while (s < SvEND(sv)) { + if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; + s++; + } + } + } + break; case OP_REPEAT: - if (o->op_private & OPpREPEAT_DOLIST) goto nope; - break; + if (o->op_private & OPpREPEAT_DOLIST) goto nope; + break; case OP_SREFGEN: - if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST - || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) - goto nope; + if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST + || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) + goto nope; } if (PL_parser && PL_parser->error_count) - goto nope; /* Don't try to run w/ errors */ + goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { switch (curop->op_type) { @@ -6145,8 +6145,8 @@ S_fold_constants(pTHX_ OP *const o) default: /* No other op types are considered foldable */ - goto nope; - } + goto nope; + } } curop = LINKLIST(o); @@ -6169,35 +6169,35 @@ S_fold_constants(pTHX_ OP *const o) /* Effective $^W=1. */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; ret = S_fold_constants_eval(aTHX); switch (ret) { case 0: - sv = *(PL_stack_sp--); - if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ - pad_swipe(o->op_targ, FALSE); - } - else if (SvTEMP(sv)) { /* grab mortal temp? */ - SvREFCNT_inc_simple_void(sv); - SvTEMP_off(sv); - } - else { assert(SvIMMORTAL(sv)); } - break; + sv = *(PL_stack_sp--); + if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ + pad_swipe(o->op_targ, FALSE); + } + else if (SvTEMP(sv)) { /* grab mortal temp? */ + SvREFCNT_inc_simple_void(sv); + SvTEMP_off(sv); + } + else { assert(SvIMMORTAL(sv)); } + break; case 3: - /* Something tried to die. Abandon constant folding. */ - /* Pretend the error never happened. */ - CLEAR_ERRSV(); - o->op_next = old_next; - break; + /* Something tried to die. Abandon constant folding. */ + /* Pretend the error never happened. */ + CLEAR_ERRSV(); + o->op_next = old_next; + break; default: - /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ - PL_warnhook = oldwarnhook; - PL_diehook = olddiehook; - /* XXX note that this croak may fail as we've already blown away - * the stack - eg any nested evals */ - Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); + /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + /* XXX note that this croak may fail as we've already blown away + * the stack - eg any nested evals */ + Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; @@ -6212,7 +6212,7 @@ S_fold_constants(pTHX_ OP *const o) delete_eval_scope(); } if (ret) - goto nope; + goto nope; /* OP_STRINGIFY and constant folding are used to implement qq. Here the constant folding is an implementation detail that we @@ -6222,10 +6222,10 @@ S_fold_constants(pTHX_ OP *const o) op_free(o); assert(sv); if (is_stringify) - SvPADTMP_off(sv); + SvPADTMP_off(sv); else if (!SvIMMORTAL(sv)) { - SvPADTMP_on(sv); - SvREADONLY_on(sv); + SvPADTMP_on(sv); + SvREADONLY_on(sv); } newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); if (!is_stringify) newop->op_folded = 1; @@ -6257,17 +6257,17 @@ S_gen_constant_list(pTHX_ OP *o) list(o); if (PL_parser && PL_parser->error_count) - return; /* Don't attempt to run with errors */ + return; /* Don't attempt to run with errors */ curop = LINKLIST(o); old_next = o->op_next; o->op_next = 0; op_was_null = o->op_type == OP_NULL; if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */ - o->op_type = OP_CUSTOM; + o->op_type = OP_CUSTOM; CALL_PEEP(curop); if (op_was_null) - o->op_type = OP_NULL; + o->op_type = OP_NULL; S_prune_chain_head(&curop); PL_op = curop; @@ -6286,30 +6286,30 @@ S_gen_constant_list(pTHX_ OP *o) /* Effective $^W=1. */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; switch (ret) { case 0: #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */ #endif - Perl_pp_pushmark(aTHX); - CALLRUNOPS(aTHX); - PL_op = curop; - assert (!(curop->op_flags & OPf_SPECIAL)); - assert(curop->op_type == OP_RANGE); - Perl_pp_anonlist(aTHX); - break; + Perl_pp_pushmark(aTHX); + CALLRUNOPS(aTHX); + PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); + Perl_pp_anonlist(aTHX); + break; case 3: - CLEAR_ERRSV(); - o->op_next = old_next; - break; + CLEAR_ERRSV(); + o->op_next = old_next; + break; default: - JMPENV_POP; - PL_warnhook = oldwarnhook; - PL_diehook = olddiehook; - Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", - ret); + JMPENV_POP; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", + ret); } JMPENV_POP; @@ -6324,7 +6324,7 @@ S_gen_constant_list(pTHX_ OP *o) delete_eval_scope(); } if (ret) - return; + return; OpTYPE_set(o, OP_RV2AV); o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ @@ -6338,11 +6338,11 @@ S_gen_constant_list(pTHX_ OP *o) op_free(curop); if (AvFILLp(av) != -1) - for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) - { - SvPADTMP_on(*svp); - SvREADONLY_on(*svp); - } + for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) + { + SvPADTMP_on(*svp); + SvREADONLY_on(*svp); + } LINKLIST(o); list(o); return; @@ -6371,15 +6371,15 @@ OP * Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (first->op_type != (unsigned)type - || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { - return newLISTOP(type, 0, first, last); + return newLISTOP(type, 0, first, last); } op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); @@ -6404,16 +6404,16 @@ OP * Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (first->op_type != (unsigned)type) - return op_prepend_elem(type, first, last); + return op_prepend_elem(type, first, last); if (last->op_type != (unsigned)type) - return op_append_elem(type, first, last); + return op_append_elem(type, first, last); OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; @@ -6442,22 +6442,22 @@ OP * Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (last->op_type == (unsigned)type) { - if (type == OP_LIST) { /* already a PUSHMARK there */ + if (type == OP_LIST) { /* already a PUSHMARK there */ /* insert 'first' after pushmark */ op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first); if (!(first->op_flags & OPf_PARENS)) last->op_flags &= ~OPf_PARENS; - } - else + } + else op_sibling_splice(last, NULL, 0, first); - last->op_flags |= OPf_KIDS; - return last; + last->op_flags |= OPf_KIDS; + return last; } return newLISTOP(type, 0, first, last); @@ -6485,18 +6485,18 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) o = force_list(o, 0); else { - o->op_flags &= ~OPf_WANT; - o->op_private &= ~OPpLVAL_INTRO; + o->op_flags &= ~OPf_WANT; + o->op_private &= ~OPpLVAL_INTRO; } if (!(PL_opargs[type] & OA_MARK)) - op_null(cLISTOPo->op_first); + op_null(cLISTOPo->op_first); else { - OP * const kid2 = OpSIBLING(cLISTOPo->op_first); - if (kid2 && kid2->op_type == OP_COREARGS) { - op_null(cLISTOPo->op_first); - kid2->op_private |= OPpCOREARGS_PUSHMARK; - } + OP * const kid2 = OpSIBLING(cLISTOPo->op_first); + if (kid2 && kid2->op_type == OP_COREARGS) { + op_null(cLISTOPo->op_first); + kid2->op_private |= OPpCOREARGS_PUSHMARK; + } } if (type != OP_SPLIT) @@ -6508,11 +6508,11 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) o->op_flags |= flags; if (flags & OPf_FOLDED) - o->op_folded = 1; + o->op_folded = 1; o = CHECKOP(type, o); if (o->op_type != (unsigned)type) - return o; + return o; return fold_constants(op_integerize(op_std_init(o))); } @@ -6560,7 +6560,7 @@ S_force_list(pTHX_ OP *o, bool nullit) rest = OpSIBLING(o); OpLASTSIB_set(o, NULL); } - o = newLISTOP(OP_LIST, 0, o, NULL); + o = newLISTOP(OP_LIST, 0, o, NULL); if (rest) op_sibling_splice(o, cLISTOPo->op_last, 0, rest); } @@ -6598,29 +6598,29 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); NewOp(1101, listop, 1, LISTOP); OpTYPE_set(listop, type); if (first || last) - flags |= OPf_KIDS; + flags |= OPf_KIDS; listop->op_flags = (U8)flags; if (!last && first) - last = first; + last = first; else if (!first && last) - first = last; + first = last; else if (first) - OpMORESIB_set(first, last); + OpMORESIB_set(first, last); listop->op_first = first; listop->op_last = last; if (pushop) { - OpMORESIB_set(pushop, first); - listop->op_first = pushop; - listop->op_flags |= OPf_KIDS; - if (!last) - listop->op_last = pushop; + OpMORESIB_set(pushop, first); + listop->op_first = pushop; + listop->op_flags |= OPf_KIDS; + if (!last) + listop->op_last = pushop; } if (listop->op_last) OpLASTSIB_set(listop->op_last, (OP*)listop); @@ -6645,14 +6645,14 @@ Perl_newOP(pTHX_ I32 type, I32 flags) OP *o; if (type == -OP_ENTEREVAL) { - type = OP_ENTEREVAL; - flags |= OPpEVAL_BYTES<<8; + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; } assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, o, 1, OP); OpTYPE_set(o, type); @@ -6661,9 +6661,9 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) - scalar(o); + scalar(o); if (PL_opargs[type] & OA_TARGET) - o->op_targ = pad_alloc(type, SVs_PADTMP); + o->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, o); } @@ -6689,24 +6689,24 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) UNOP *unop; if (type == -OP_ENTEREVAL) { - type = OP_ENTEREVAL; - flags |= OPpEVAL_BYTES<<8; + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; } assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP - || type == OP_SASSIGN - || type == OP_ENTERTRY + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_SASSIGN + || type == OP_ENTERTRY || type == OP_ENTERTRYCATCH - || type == OP_CUSTOM - || type == OP_NULL ); + || type == OP_CUSTOM + || type == OP_NULL ); if (!first) - first = newOP(OP_STUB, 0); + first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) - first = force_list(first, 1); + first = force_list(first, 1); NewOp(1101, unop, 1, UNOP); OpTYPE_set(unop, type); @@ -6719,7 +6719,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) - return (OP*)unop; + return (OP*)unop; return fold_constants(op_integerize(op_std_init((OP *) unop))); } @@ -6852,22 +6852,22 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) BINOP *binop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP - || type == OP_NULL || type == OP_CUSTOM); + || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); if (!first) - first = newOP(OP_NULL, 0); + first = newOP(OP_NULL, 0); OpTYPE_set(binop, type); binop->op_first = first; binop->op_flags = (U8)(flags | OPf_KIDS); if (!last) { - last = first; - binop->op_private = (U8)(1 | (flags >> 8)); + last = first; + binop->op_private = (U8)(1 | (flags >> 8)); } else { - binop->op_private = (U8)(2 | (flags >> 8)); + binop->op_private = (U8)(2 | (flags >> 8)); OpMORESIB_set(first, last); } @@ -6880,7 +6880,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) - return (OP*)binop; + return (OP*)binop; return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -6903,10 +6903,10 @@ Perl_invmap_dump(pTHX_ SV* invlist, UV *map) PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start); if (end == IV_MAX) { PerlIO_printf(Perl_debug_log, " .. INFTY"); - } - else if (end != start) { + } + else if (end != start) { PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end); - } + } else { PerlIO_printf(Perl_debug_log, " "); } @@ -7933,7 +7933,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } /* The inversion map is pushed; first the list. */ - invmap = MUTABLE_AV(newAV()); + invmap = MUTABLE_AV(newAV()); av_push(invmap, t_invlist); /* 2nd is the mapping */ @@ -8077,9 +8077,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) Safefree(r_map); if(del && rlen != 0 && r_count == t_count) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); } else if(r_count > t_count) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } op_free(expr); @@ -8105,25 +8105,25 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PMOP *pmop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); NewOp(1101, pmop, 1, PMOP); OpTYPE_set(pmop, type); pmop->op_flags = (U8)flags; pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP *)pmop); + scalar((OP *)pmop); if (PL_hints & HINT_RE_TAINT) - pmop->op_pmflags |= PMf_RETAINT; + pmop->op_pmflags |= PMf_RETAINT; #ifdef USE_LOCALE_CTYPE if (IN_LC_COMPILETIME(LC_CTYPE)) { - set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); + set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } else #endif if (IN_UNI_8_BIT) { - set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); + set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ @@ -8142,23 +8142,23 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) #ifdef USE_ITHREADS assert(SvPOK(PL_regex_pad[0])); if (SvCUR(PL_regex_pad[0])) { - /* Pop off the "packed" IV from the end. */ - SV *const repointer_list = PL_regex_pad[0]; - const char *p = SvEND(repointer_list) - sizeof(IV); - const IV offset = *((IV*)p); + /* Pop off the "packed" IV from the end. */ + SV *const repointer_list = PL_regex_pad[0]; + const char *p = SvEND(repointer_list) - sizeof(IV); + const IV offset = *((IV*)p); - assert(SvCUR(repointer_list) % sizeof(IV) == 0); + assert(SvCUR(repointer_list) % sizeof(IV) == 0); - SvEND_set(repointer_list, p); + SvEND_set(repointer_list, p); - pmop->op_pmoffset = offset; - /* This slot should be free, so assert this: */ - assert(PL_regex_pad[offset] == &PL_sv_undef); + pmop->op_pmoffset = offset; + /* This slot should be free, so assert this: */ + assert(PL_regex_pad[offset] == &PL_sv_undef); } else { - SV * const repointer = &PL_sv_undef; - av_push(PL_regex_padav, repointer); - pmop->op_pmoffset = av_top_index(PL_regex_padav); - PL_regex_pad = AvARRAY(PL_regex_padav); + SV * const repointer = &PL_sv_undef; + av_push(PL_regex_padav, repointer); + pmop->op_pmoffset = av_top_index(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); } #endif @@ -8172,11 +8172,11 @@ S_set_haseval(pTHX) PL_cv_has_eval = 1; /* Any pad names in scope are potentially lvalues. */ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) { - PADNAME *pn = PAD_COMPNAME_SV(i); - if (!pn || !PadnameLEN(pn)) - continue; - if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax)) - S_mark_padname_lvalue(aTHX_ pn); + PADNAME *pn = PAD_COMPNAME_SV(i); + if (!pn || !PadnameLEN(pn)) + continue; + if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax)) + S_mark_padname_lvalue(aTHX_ pn); } } @@ -8246,7 +8246,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) } } else if (expr->op_type != OP_CONST) - is_compiletime = 0; + is_compiletime = 0; LINKLIST(expr); @@ -8322,8 +8322,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); if (is_compiletime) { - U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; - regexp_engine const *eng = current_re_engine(); + U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + regexp_engine const *eng = current_re_engine(); if (is_split) { /* make engine handle split ' ' specially */ @@ -8331,30 +8331,30 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) rx_flags |= RXf_SPLIT; } - if (!has_code || !eng->op_comp) { - /* compile-time simple constant pattern */ - - if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { - /* whoops! we guessed that a qr// had a code block, but we - * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv - * that isn't required now. Note that we have to be pretty - * confident that nothing used that CV's pad while the - * regex was parsed, except maybe op targets for \Q etc. - * If there were any op targets, though, they should have - * been stolen by constant folding. - */ + if (!has_code || !eng->op_comp) { + /* compile-time simple constant pattern */ + + if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { + /* whoops! we guessed that a qr// had a code block, but we + * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv + * that isn't required now. Note that we have to be pretty + * confident that nothing used that CV's pad while the + * regex was parsed, except maybe op targets for \Q etc. + * If there were any op targets, though, they should have + * been stolen by constant folding. + */ #ifdef DEBUGGING - SSize_t i = 0; - assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); - while (++i <= AvFILLp(PL_comppad)) { + SSize_t i = 0; + assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); + while (++i <= AvFILLp(PL_comppad)) { # ifdef USE_PAD_RESET /* under USE_PAD_RESET, pad swipe replaces a swiped * folded constant with a fresh padtmp */ - assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); + assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); # else - assert(!PL_curpad[i]); + assert(!PL_curpad[i]); # endif - } + } #endif /* This LEAVE_SCOPE will restore PL_compcv to point to the * outer CV (the one whose slab holds the pm op). The @@ -8363,212 +8363,212 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) * return from this function. Which is why its safe to * call op_free(expr) below. */ - LEAVE_SCOPE(floor); - pm->op_pmflags &= ~PMf_HAS_CV; - } + LEAVE_SCOPE(floor); + pm->op_pmflags &= ~PMf_HAS_CV; + } /* Skip compiling if parser found an error for this pattern */ if (pm->op_pmflags & PMf_HAS_ERROR) { return o; } - PM_SETRE(pm, - eng->op_comp - ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, - rx_flags, pm->op_pmflags) - : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, - rx_flags, pm->op_pmflags) - ); - op_free(expr); - } - else { - /* compile-time pattern that includes literal code blocks */ + PM_SETRE(pm, + eng->op_comp + ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + ); + op_free(expr); + } + else { + /* compile-time pattern that includes literal code blocks */ - REGEXP* re; + REGEXP* re; /* Skip compiling if parser found an error for this pattern */ if (pm->op_pmflags & PMf_HAS_ERROR) { return o; } - re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, - rx_flags, - (pm->op_pmflags | - ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) - ); - PM_SETRE(pm, re); - if (pm->op_pmflags & PMf_HAS_CV) { - CV *cv; - /* this QR op (and the anon sub we embed it in) is never - * actually executed. It's just a placeholder where we can - * squirrel away expr in op_code_list without the peephole - * optimiser etc processing it for a second time */ - OP *qr = newPMOP(OP_QR, 0); - ((PMOP*)qr)->op_code_list = expr; - - /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ - SvREFCNT_inc_simple_void(PL_compcv); - cv = newATTRSUB(floor, 0, NULL, NULL, qr); - ReANY(re)->qr_anoncv = cv; - - /* attach the anon CV to the pad so that - * pad_fixup_inner_anons() can find it */ - (void)pad_add_anon(cv, o->op_type); - SvREFCNT_inc_simple_void(cv); - } - else { - pm->op_code_list = expr; - } - } + re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, + (pm->op_pmflags | + ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) + ); + PM_SETRE(pm, re); + if (pm->op_pmflags & PMf_HAS_CV) { + CV *cv; + /* this QR op (and the anon sub we embed it in) is never + * actually executed. It's just a placeholder where we can + * squirrel away expr in op_code_list without the peephole + * optimiser etc processing it for a second time */ + OP *qr = newPMOP(OP_QR, 0); + ((PMOP*)qr)->op_code_list = expr; + + /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ + SvREFCNT_inc_simple_void(PL_compcv); + cv = newATTRSUB(floor, 0, NULL, NULL, qr); + ReANY(re)->qr_anoncv = cv; + + /* attach the anon CV to the pad so that + * pad_fixup_inner_anons() can find it */ + (void)pad_add_anon(cv, o->op_type); + SvREFCNT_inc_simple_void(cv); + } + else { + pm->op_code_list = expr; + } + } } else { - /* runtime pattern: build chain of regcomp etc ops */ - bool reglist; - PADOFFSET cv_targ = 0; - - reglist = isreg && expr->op_type == OP_LIST; - if (reglist) - op_null(expr); - - if (has_code) { - pm->op_code_list = expr; - /* don't free op_code_list; its ops are embedded elsewhere too */ - pm->op_pmflags |= PMf_CODELIST_PRIVATE; - } + /* runtime pattern: build chain of regcomp etc ops */ + bool reglist; + PADOFFSET cv_targ = 0; + + reglist = isreg && expr->op_type == OP_LIST; + if (reglist) + op_null(expr); + + if (has_code) { + pm->op_code_list = expr; + /* don't free op_code_list; its ops are embedded elsewhere too */ + pm->op_pmflags |= PMf_CODELIST_PRIVATE; + } if (is_split) /* make engine handle split ' ' specially */ pm->op_pmflags |= PMf_SPLIT; - /* the OP_REGCMAYBE is a placeholder in the non-threaded case - * to allow its op_next to be pointed past the regcomp and - * preceding stacking ops; - * OP_REGCRESET is there to reset taint before executing the - * stacking ops */ - if (pm->op_pmflags & PMf_KEEP || TAINTING_get) - expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); - - if (pm->op_pmflags & PMf_HAS_CV) { - /* we have a runtime qr with literal code. This means - * that the qr// has been wrapped in a new CV, which - * means that runtime consts, vars etc will have been compiled - * against a new pad. So... we need to execute those ops - * within the environment of the new CV. So wrap them in a call - * to a new anon sub. i.e. for - * - * qr/a$b(?{...})/, - * - * we build an anon sub that looks like - * - * sub { "a", $b, '(?{...})' } - * - * and call it, passing the returned list to regcomp. - * Or to put it another way, the list of ops that get executed - * are: - * - * normal PMf_HAS_CV - * ------ ------------------- - * pushmark (for regcomp) - * pushmark (for entersub) - * anoncode - * srefgen - * entersub - * regcreset regcreset - * pushmark pushmark - * const("a") const("a") - * gvsv(b) gvsv(b) - * const("(?{...})") const("(?{...})") - * leavesub - * regcomp regcomp - */ - - SvREFCNT_inc_simple_void(PL_compcv); - CvLVALUE_on(PL_compcv); - /* these lines are just an unrolled newANONATTRSUB */ - expr = newSVOP(OP_ANONCODE, 0, - MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); - cv_targ = expr->op_targ; - expr = newUNOP(OP_REFGEN, 0, expr); - - expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); - } + /* the OP_REGCMAYBE is a placeholder in the non-threaded case + * to allow its op_next to be pointed past the regcomp and + * preceding stacking ops; + * OP_REGCRESET is there to reset taint before executing the + * stacking ops */ + if (pm->op_pmflags & PMf_KEEP || TAINTING_get) + expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); + + if (pm->op_pmflags & PMf_HAS_CV) { + /* we have a runtime qr with literal code. This means + * that the qr// has been wrapped in a new CV, which + * means that runtime consts, vars etc will have been compiled + * against a new pad. So... we need to execute those ops + * within the environment of the new CV. So wrap them in a call + * to a new anon sub. i.e. for + * + * qr/a$b(?{...})/, + * + * we build an anon sub that looks like + * + * sub { "a", $b, '(?{...})' } + * + * and call it, passing the returned list to regcomp. + * Or to put it another way, the list of ops that get executed + * are: + * + * normal PMf_HAS_CV + * ------ ------------------- + * pushmark (for regcomp) + * pushmark (for entersub) + * anoncode + * srefgen + * entersub + * regcreset regcreset + * pushmark pushmark + * const("a") const("a") + * gvsv(b) gvsv(b) + * const("(?{...})") const("(?{...})") + * leavesub + * regcomp regcomp + */ - rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o); - rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) - | (reglist ? OPf_STACKED : 0); - rcop->op_targ = cv_targ; + SvREFCNT_inc_simple_void(PL_compcv); + CvLVALUE_on(PL_compcv); + /* these lines are just an unrolled newANONATTRSUB */ + expr = newSVOP(OP_ANONCODE, 0, + MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); + cv_targ = expr->op_targ; + expr = newUNOP(OP_REFGEN, 0, expr); - /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ - if (PL_hints & HINT_RE_EVAL) - S_set_haseval(aTHX); + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); + } - /* establish postfix order */ - if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { - LINKLIST(expr); - rcop->op_next = expr; - ((UNOP*)expr)->op_first->op_next = (OP*)rcop; - } - else { - rcop->op_next = LINKLIST(expr); - expr->op_next = (OP*)rcop; - } + rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o); + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); + rcop->op_targ = cv_targ; + + /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ + if (PL_hints & HINT_RE_EVAL) + S_set_haseval(aTHX); + + /* establish postfix order */ + if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { + LINKLIST(expr); + rcop->op_next = expr; + ((UNOP*)expr)->op_first->op_next = (OP*)rcop; + } + else { + rcop->op_next = LINKLIST(expr); + expr->op_next = (OP*)rcop; + } - op_prepend_elem(o->op_type, scalar((OP*)rcop), o); + op_prepend_elem(o->op_type, scalar((OP*)rcop), o); } if (repl) { - OP *curop = repl; - bool konst; - /* If we are looking at s//.../e with a single statement, get past - the implicit do{}. */ - if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS + OP *curop = repl; + bool konst; + /* If we are looking at s//.../e with a single statement, get past + the implicit do{}. */ + if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS && cUNOPx(curop)->op_first->op_type == OP_SCOPE && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { OP *sib; - OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; - if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid)) - && !OpHAS_SIBLING(sib)) - curop = sib; - } - if (curop->op_type == OP_CONST) - konst = TRUE; - else if (( (curop->op_type == OP_RV2SV || - curop->op_type == OP_RV2AV || - curop->op_type == OP_RV2HV || - curop->op_type == OP_RV2GV) - && cUNOPx(curop)->op_first - && cUNOPx(curop)->op_first->op_type == OP_GV ) - || curop->op_type == OP_PADSV - || curop->op_type == OP_PADAV - || curop->op_type == OP_PADHV - || curop->op_type == OP_PADANY) { - repl_has_vars = 1; - konst = TRUE; - } - else konst = FALSE; - if (konst - && !(repl_has_vars - && (!PM_GETRE(pm) - || !RX_PRELEN(PM_GETRE(pm)) - || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) - { - pm->op_pmflags |= PMf_CONST; /* const for long enough */ - op_prepend_elem(o->op_type, scalar(repl), o); - } - else { + OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; + if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid)) + && !OpHAS_SIBLING(sib)) + curop = sib; + } + if (curop->op_type == OP_CONST) + konst = TRUE; + else if (( (curop->op_type == OP_RV2SV || + curop->op_type == OP_RV2AV || + curop->op_type == OP_RV2HV || + curop->op_type == OP_RV2GV) + && cUNOPx(curop)->op_first + && cUNOPx(curop)->op_first->op_type == OP_GV ) + || curop->op_type == OP_PADSV + || curop->op_type == OP_PADAV + || curop->op_type == OP_PADHV + || curop->op_type == OP_PADANY) { + repl_has_vars = 1; + konst = TRUE; + } + else konst = FALSE; + if (konst + && !(repl_has_vars + && (!PM_GETRE(pm) + || !RX_PRELEN(PM_GETRE(pm)) + || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) + { + pm->op_pmflags |= PMf_CONST; /* const for long enough */ + op_prepend_elem(o->op_type, scalar(repl), o); + } + else { rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o); - rcop->op_private = 1; + rcop->op_private = 1; - /* establish postfix order */ - rcop->op_next = LINKLIST(repl); - repl->op_next = (OP*)rcop; + /* establish postfix order */ + rcop->op_next = LINKLIST(repl); + repl->op_next = (OP*)rcop; - pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); - assert(!(pm->op_pmflags & PMf_ONCE)); - pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); - rcop->op_next = 0; - } + pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); + assert(!(pm->op_pmflags & PMf_ONCE)); + pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); + rcop->op_next = 0; + } } return (OP*)pm; @@ -8593,9 +8593,9 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWSVOP; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP - || type == OP_CUSTOM); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); NewOp(1101, svop, 1, SVOP); OpTYPE_set(svop, type); @@ -8604,9 +8604,9 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) svop->op_flags = (U8)flags; svop->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)svop); + scalar((OP*)svop); if (PL_opargs[type] & OA_TARGET) - svop->op_targ = pad_alloc(type, SVs_PADTMP); + svop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, svop); } @@ -8621,7 +8621,7 @@ Constructs and returns an op to access C<$_>. OP * Perl_newDEFSVOP(pTHX) { - return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); + return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } #ifdef USE_ITHREADS @@ -8648,23 +8648,23 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWPADOP; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP - || type == OP_CUSTOM); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); NewOp(1101, padop, 1, PADOP); OpTYPE_set(padop, type); padop->op_padix = - pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)padop); + scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) - padop->op_targ = pad_alloc(type, SVs_PADTMP); + padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } @@ -8716,8 +8716,8 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) flags &= ~SVf_UTF8; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || type == OP_RUNCV || type == OP_CUSTOM - || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + || type == OP_RUNCV || type == OP_CUSTOM + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); OpTYPE_set(pvop, type); @@ -8726,9 +8726,9 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) pvop->op_flags = (U8)flags; pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)pvop); + scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) - pvop->op_targ = pad_alloc(type, SVs_PADTMP); + pvop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, pvop); } @@ -8774,98 +8774,98 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PERL_ARGS_ASSERT_UTILIZE; if (idop->op_type != OP_CONST) - Perl_croak(aTHX_ "Module name must be constant"); + Perl_croak(aTHX_ "Module name must be constant"); veop = NULL; if (version) { - SV * const vesv = ((SVOP*)version)->op_sv; + SV * const vesv = ((SVOP*)version)->op_sv; - if (!arg && !SvNIOKp(vesv)) { - arg = version; - } - else { - OP *pack; - SV *meth; + if (!arg && !SvNIOKp(vesv)) { + arg = version; + } + else { + OP *pack; + SV *meth; - if (version->op_type != OP_CONST || !SvNIOKp(vesv)) - Perl_croak(aTHX_ "Version number must be a constant number"); + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) + Perl_croak(aTHX_ "Version number must be a constant number"); - /* Make copy of idop so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); - /* Fake up a method call to VERSION */ - meth = newSVpvs_share("VERSION"); - veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, pack, version), - newMETHOP_named(OP_METHOD_NAMED, 0, meth))); - } + /* Fake up a method call to VERSION */ + meth = newSVpvs_share("VERSION"); + veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, version), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); + } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { - imop = arg; /* no import on explicit () */ + imop = arg; /* no import on explicit () */ } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { - imop = NULL; /* use 5.0; */ - if (aver) - use_version = ((SVOP*)idop)->op_sv; - else - idop->op_private |= OPpCONST_NOVER; + imop = NULL; /* use 5.0; */ + if (aver) + use_version = ((SVOP*)idop)->op_sv; + else + idop->op_private |= OPpCONST_NOVER; } else { - SV *meth; + SV *meth; - /* Make copy of idop so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); - /* Fake up a method call to import/unimport */ - meth = aver - ? newSVpvs_share("import") : newSVpvs_share("unimport"); - imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, pack, arg), - newMETHOP_named(OP_METHOD_NAMED, 0, meth) - )); + /* Fake up a method call to import/unimport */ + meth = aver + ? newSVpvs_share("import") : newSVpvs_share("unimport"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth) + )); } /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, - newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), - NULL, - NULL, - op_append_elem(OP_LINESEQ, - op_append_elem(OP_LINESEQ, - newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), - newSTATEOP(0, NULL, veop)), - newSTATEOP(0, NULL, imop) )); + newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), + NULL, + NULL, + op_append_elem(OP_LINESEQ, + op_append_elem(OP_LINESEQ, + newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), + newSTATEOP(0, NULL, veop)), + newSTATEOP(0, NULL, imop) )); if (use_version) { - /* Enable the - * feature bundle that corresponds to the required version. */ - use_version = sv_2mortal(new_version(use_version)); - S_enable_feature_bundle(aTHX_ use_version); - - /* If a version >= 5.11.0 is requested, strictures are on by default! */ - if (vcmp(use_version, - sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { - if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) - PL_hints |= HINT_STRICT_REFS; - if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) - PL_hints |= HINT_STRICT_SUBS; - if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) - PL_hints |= HINT_STRICT_VARS; - } - /* otherwise they are off */ - else { - if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) - PL_hints &= ~HINT_STRICT_REFS; - if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) - PL_hints &= ~HINT_STRICT_SUBS; - if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) - PL_hints &= ~HINT_STRICT_VARS; - } + /* Enable the + * feature bundle that corresponds to the required version. */ + use_version = sv_2mortal(new_version(use_version)); + S_enable_feature_bundle(aTHX_ use_version); + + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (vcmp(use_version, + sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints |= HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints |= HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints |= HINT_STRICT_VARS; + } + /* otherwise they are off */ + else { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints &= ~HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints &= ~HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints &= ~HINT_STRICT_VARS; + } } /* The "did you use incorrect case?" warning used to be here. @@ -8988,24 +8988,24 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) modname = newSVOP(OP_CONST, 0, name); modname->op_private |= OPpCONST_BARE; if (ver) { - veop = newSVOP(OP_CONST, 0, ver); + veop = newSVOP(OP_CONST, 0, ver); } else - veop = NULL; + veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { - imop = sawparens(newNULLLIST()); + imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { - imop = va_arg(*args, OP*); + imop = va_arg(*args, OP*); } else { - SV *sv; - imop = NULL; - sv = va_arg(*args, SV*); - while (sv) { - imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); - sv = va_arg(*args, SV*); - } + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } } utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop); @@ -9016,9 +9016,9 @@ PERL_STATIC_INLINE OP * S_new_entersubop(pTHX_ GV *gv, OP *arg) { return newUNOP(OP_ENTERSUB, OPf_STACKED, - newLISTOP(OP_LIST, 0, arg, - newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv)))); + newLISTOP(OP_LIST, 0, arg, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv)))); } OP * @@ -9030,10 +9030,10 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) PERL_ARGS_ASSERT_DOFILE; if (!force_builtin && (gv = gv_override("do", 2))) { - doop = S_new_entersubop(aTHX_ gv, term); + doop = S_new_entersubop(aTHX_ gv, term); } else { - doop = newUNOP(OP_DOFILE, 0, scalar(term)); + doop = newUNOP(OP_DOFILE, 0, scalar(term)); } return doop; } @@ -9058,8 +9058,8 @@ OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, - list(force_list(subscript, 1)), - list(force_list(listval, 1)) ); + list(force_list(subscript, 1)), + list(force_list(listval, 1)) ); } #define ASSIGN_SCALAR 0 @@ -9080,24 +9080,24 @@ S_assignment_type(pTHX_ const OP *o) U8 ret; if (!o) - return ASSIGN_LIST; + return ASSIGN_LIST; if (o->op_type == OP_SREFGEN) { - OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; - type = kid->op_type; - flags = o->op_flags | kid->op_flags; - if (!(flags & OPf_PARENS) - && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || - kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) - return ASSIGN_REF; - ret = ASSIGN_REF; + OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; + type = kid->op_type; + flags = o->op_flags | kid->op_flags; + if (!(flags & OPf_PARENS) + && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || + kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) + return ASSIGN_REF; + ret = ASSIGN_REF; } else { - if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) - o = cUNOPo->op_first; - flags = o->op_flags; - type = o->op_type; - ret = ASSIGN_SCALAR; + if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) + o = cUNOPo->op_first; + flags = o->op_flags; + type = o->op_type; + ret = ASSIGN_SCALAR; } if (type == OP_COND_EXPR) { @@ -9105,29 +9105,29 @@ S_assignment_type(pTHX_ const OP *o) const I32 t = assignment_type(sib); const I32 f = assignment_type(OpSIBLING(sib)); - if (t == ASSIGN_LIST && f == ASSIGN_LIST) - return ASSIGN_LIST; - if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST)) - yyerror("Assignment to both a list and a scalar"); - return ASSIGN_SCALAR; + if (t == ASSIGN_LIST && f == ASSIGN_LIST) + return ASSIGN_LIST; + if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST)) + yyerror("Assignment to both a list and a scalar"); + return ASSIGN_SCALAR; } if (type == OP_LIST && - (flags & OPf_WANT) == OPf_WANT_SCALAR && - o->op_private & OPpLVAL_INTRO) - return ret; + (flags & OPf_WANT) == OPf_WANT_SCALAR && + o->op_private & OPpLVAL_INTRO) + return ret; if (type == OP_LIST || flags & OPf_PARENS || - type == OP_RV2AV || type == OP_RV2HV || - type == OP_ASLICE || type == OP_HSLICE || + type == OP_RV2AV || type == OP_RV2HV || + type == OP_ASLICE || type == OP_HSLICE || type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN) - return ASSIGN_LIST; + return ASSIGN_LIST; if (type == OP_PADAV || type == OP_PADHV) - return ASSIGN_LIST; + return ASSIGN_LIST; if (type == OP_RV2SV) - return ret; + return ret; return ret; } @@ -9137,12 +9137,12 @@ S_newONCEOP(pTHX_ OP *initop, OP *padop) { const PADOFFSET target = padop->op_targ; OP *const other = newOP(OP_PADSV, - padop->op_flags - | ((padop->op_private & ~OPpLVAL_INTRO) << 8)); + padop->op_flags + | ((padop->op_private & ~OPpLVAL_INTRO) << 8)); OP *const first = newOP(OP_NULL, 0); OP *const nullop = newCONDOP(0, first, initop, other); /* XXX targlex disabled for now; see ticket #124160 - newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other); + newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other); */ OP *const condop = first->op_next; @@ -9190,82 +9190,82 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) I32 assign_type; if (optype) { - if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { right = scalar(right); - return newLOGOP(optype, 0, - op_lvalue(scalar(left), optype), - newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); - } - else { - return newBINOP(optype, OPf_STACKED, - op_lvalue(scalar(left), optype), scalar(right)); - } + return newLOGOP(optype, 0, + op_lvalue(scalar(left), optype), + newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); + } + else { + return newBINOP(optype, OPf_STACKED, + op_lvalue(scalar(left), optype), scalar(right)); + } } if ((assign_type = assignment_type(left)) == ASSIGN_LIST) { - OP *state_var_op = NULL; - static const char no_list_state[] = "Initialization of state variables" - " in list currently forbidden"; - OP *curop; - - if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) - left->op_private &= ~ OPpSLICEWARNING; - - PL_modcount = 0; - left = op_lvalue(left, OP_AASSIGN); - curop = list(force_list(left, 1)); - o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); - o->op_private = (U8)(0 | (flags >> 8)); - - if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) - { - OP *lop = ((LISTOP*)left)->op_first, *vop, *eop; - if (!(left->op_flags & OPf_PARENS) && - lop->op_type == OP_PUSHMARK && - (vop = OpSIBLING(lop)) && - (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) && - !(vop->op_flags & OPf_PARENS) && - (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == - (OPpLVAL_INTRO|OPpPAD_STATE) && - (eop = OpSIBLING(vop)) && - eop->op_type == OP_ENTERSUB && - !OpHAS_SIBLING(eop)) { - state_var_op = vop; - } else { - while (lop) { - if ((lop->op_type == OP_PADSV || - lop->op_type == OP_PADAV || - lop->op_type == OP_PADHV || - lop->op_type == OP_PADANY) - && (lop->op_private & OPpPAD_STATE) - ) - yyerror(no_list_state); - lop = OpSIBLING(lop); - } - } - } - else if ( (left->op_private & OPpLVAL_INTRO) + OP *state_var_op = NULL; + static const char no_list_state[] = "Initialization of state variables" + " in list currently forbidden"; + OP *curop; + + if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) + left->op_private &= ~ OPpSLICEWARNING; + + PL_modcount = 0; + left = op_lvalue(left, OP_AASSIGN); + curop = list(force_list(left, 1)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); + o->op_private = (U8)(0 | (flags >> 8)); + + if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) + { + OP *lop = ((LISTOP*)left)->op_first, *vop, *eop; + if (!(left->op_flags & OPf_PARENS) && + lop->op_type == OP_PUSHMARK && + (vop = OpSIBLING(lop)) && + (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) && + !(vop->op_flags & OPf_PARENS) && + (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == + (OPpLVAL_INTRO|OPpPAD_STATE) && + (eop = OpSIBLING(vop)) && + eop->op_type == OP_ENTERSUB && + !OpHAS_SIBLING(eop)) { + state_var_op = vop; + } else { + while (lop) { + if ((lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) + && (lop->op_private & OPpPAD_STATE) + ) + yyerror(no_list_state); + lop = OpSIBLING(lop); + } + } + } + else if ( (left->op_private & OPpLVAL_INTRO) && (left->op_private & OPpPAD_STATE) - && ( left->op_type == OP_PADSV - || left->op_type == OP_PADAV - || left->op_type == OP_PADHV - || left->op_type == OP_PADANY) + && ( left->op_type == OP_PADSV + || left->op_type == OP_PADAV + || left->op_type == OP_PADHV + || left->op_type == OP_PADANY) ) { - /* All single variable list context state assignments, hence - state ($a) = ... - (state $a) = ... - state @a = ... - state (@a) = ... - (state @a) = ... - state %a = ... - state (%a) = ... - (state %a) = ... - */ + /* All single variable list context state assignments, hence + state ($a) = ... + (state $a) = ... + state @a = ... + state (@a) = ... + (state @a) = ... + state %a = ... + state (%a) = ... + (state %a) = ... + */ if (left->op_flags & OPf_PARENS) - yyerror(no_list_state); - else - state_var_op = left; - } + yyerror(no_list_state); + else + state_var_op = left; + } /* optimise @a = split(...) into: * @{expr}: split(..., @{expr}) (where @a is not flattened) @@ -9273,7 +9273,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * the split op itself) */ - if ( right + if ( right && right->op_type == OP_SPLIT /* don't do twice, e.g. @b = (@a = split) */ && !(right->op_private & OPpSPLIT_ASSIGN)) @@ -9355,24 +9355,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } } - } + } - if (state_var_op) - o = S_newONCEOP(aTHX_ o, state_var_op); - return o; + if (state_var_op) + o = S_newONCEOP(aTHX_ o, state_var_op); + return o; } if (assign_type == ASSIGN_REF) - return newBINOP(OP_REFASSIGN, flags, scalar(right), left); + return newBINOP(OP_REFASSIGN, flags, scalar(right), left); if (!right) - right = newOP(OP_UNDEF, 0); + right = newOP(OP_UNDEF, 0); if (right->op_type == OP_READLINE) { - right->op_flags |= OPf_STACKED; - return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), - scalar(right)); + right->op_flags |= OPf_STACKED; + return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), + scalar(right)); } else { - o = newBINOP(OP_SASSIGN, flags, - scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); + o = newBINOP(OP_SASSIGN, flags, + scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); } return o; } @@ -9424,13 +9424,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); if (label) { - Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); - PL_hints |= HINT_BLOCK_SCOPE; - /* It seems that we need to defer freeing this pointer, as other parts - of the grammar end up wanting to copy it after this op has been - created. */ - SAVEFREEPV(label); + PL_hints |= HINT_BLOCK_SCOPE; + /* It seems that we need to defer freeing this pointer, as other parts + of the grammar end up wanting to copy it after this op has been + created. */ + SAVEFREEPV(label); } if (PL_parser->preambling != NOLINE) { @@ -9440,8 +9440,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) else if (PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { - CopLINE_set(cop, PL_parser->copline); - PL_parser->copline = NOLINE; + CopLINE_set(cop, PL_parser->copline); + PL_parser->copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ @@ -9451,19 +9451,19 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopSTASH_set(cop, PL_curstash); if (cop->op_type == OP_DBSTATE) { - /* this line can have a breakpoint - store the cop in IV */ - AV *av = CopFILEAVx(PL_curcop); - if (av) { - SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef ) { - (void)SvIOK_on(*svp); - SvIV_set(*svp, PTR2IV(cop)); - } - } + /* this line can have a breakpoint - store the cop in IV */ + AV *av = CopFILEAVx(PL_curcop); + if (av) { + SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); + SvIV_set(*svp, PTR2IV(cop)); + } + } } if (flags & OPf_SPECIAL) - op_null((OP*)cop); + op_null((OP*)cop); return op_prepend_elem(OP_LINESEQ, (OP*)cop, o); } @@ -9502,43 +9502,43 @@ S_search_const(pTHX_ OP *o) redo: switch (o->op_type) { - case OP_CONST: - return o; - case OP_NULL: - if (o->op_flags & OPf_KIDS) { - o = cUNOPo->op_first; + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) { + o = cUNOPo->op_first; goto redo; } - break; - case OP_LEAVE: - case OP_SCOPE: - case OP_LINESEQ: - { - OP *kid; - if (!(o->op_flags & OPf_KIDS)) - return NULL; - kid = cLISTOPo->op_first; - - do { - switch (kid->op_type) { - case OP_ENTER: - case OP_NULL: - case OP_NEXTSTATE: - kid = OpSIBLING(kid); - break; - default: - if (kid != cLISTOPo->op_last) - return NULL; - goto last; - } - } while (kid); - - if (!kid) - kid = cLISTOPo->op_last; + break; + case OP_LEAVE: + case OP_SCOPE: + case OP_LINESEQ: + { + OP *kid; + if (!(o->op_flags & OPf_KIDS)) + return NULL; + kid = cLISTOPo->op_first; + + do { + switch (kid->op_type) { + case OP_ENTER: + case OP_NULL: + case OP_NEXTSTATE: + kid = OpSIBLING(kid); + break; + default: + if (kid != cLISTOPo->op_last) + return NULL; + goto last; + } + } while (kid); + + if (!kid) + kid = cLISTOPo->op_last; last: - o = kid; + o = kid; goto redo; - } + } } return NULL; @@ -9569,138 +9569,138 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) case OP_NEXT: case OP_LAST: case OP_REDO: - /* XXX: Perhaps we should emit a stronger warning for these. - Even with the high-precedence operator they don't seem to do - anything sensible. + /* XXX: Perhaps we should emit a stronger warning for these. + Even with the high-precedence operator they don't seem to do + anything sensible. - But until we do, fall through here. + But until we do, fall through here. */ case OP_RETURN: case OP_EXIT: case OP_DIE: case OP_GOTO: - /* XXX: Currently we allow people to "shoot themselves in the - foot" by explicitly writing "(return $a) or $b". + /* XXX: Currently we allow people to "shoot themselves in the + foot" by explicitly writing "(return $a) or $b". - Warn unless we are looking at the result from folding or if - the programmer explicitly grouped the operators like this. - The former can occur with e.g. + Warn unless we are looking at the result from folding or if + the programmer explicitly grouped the operators like this. + The former can occur with e.g. - use constant FEATURE => ( $] >= ... ); - sub { not FEATURE and return or do_stuff(); } - */ - if (!first->op_folded && !(first->op_flags & OPf_PARENS)) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Possible precedence issue with control flow operator"); - /* XXX: Should we optimze this to "return $a;" (i.e. remove - the "or $b" part)? - */ - break; + use constant FEATURE => ( $] >= ... ); + sub { not FEATURE and return or do_stuff(); } + */ + if (!first->op_folded && !(first->op_flags & OPf_PARENS)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Possible precedence issue with control flow operator"); + /* XXX: Should we optimze this to "return $a;" (i.e. remove + the "or $b" part)? + */ + break; } if (type == OP_XOR) /* Not short circuit, but here by precedence. */ - return newBINOP(type, flags, scalar(first), scalar(other)); + return newBINOP(type, flags, scalar(first), scalar(other)); assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); scalarboolean(first); /* search for a constant op that could let us fold the test */ if ((cstop = search_const(first))) { - if (cstop->op_private & OPpCONST_STRICT) - no_bareword_allowed(cstop); - else if ((cstop->op_private & OPpCONST_BARE)) - Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); - if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || - (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || - (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { + if (cstop->op_private & OPpCONST_STRICT) + no_bareword_allowed(cstop); + else if ((cstop->op_private & OPpCONST_BARE)) + Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); + if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { /* Elide the (constant) lhs, since it can't affect the outcome */ - *firstp = NULL; - if (other->op_type == OP_CONST) - other->op_private |= OPpCONST_SHORTCIRCUIT; - op_free(first); - if (other->op_type == OP_LEAVE) - other = newUNOP(OP_NULL, OPf_SPECIAL, other); - else if (other->op_type == OP_MATCH - || other->op_type == OP_SUBST - || other->op_type == OP_TRANSR - || other->op_type == OP_TRANS) - /* Mark the op as being unbindable with =~ */ - other->op_flags |= OPf_SPECIAL; - - other->op_folded = 1; - return other; - } - else { + *firstp = NULL; + if (other->op_type == OP_CONST) + other->op_private |= OPpCONST_SHORTCIRCUIT; + op_free(first); + if (other->op_type == OP_LEAVE) + other = newUNOP(OP_NULL, OPf_SPECIAL, other); + else if (other->op_type == OP_MATCH + || other->op_type == OP_SUBST + || other->op_type == OP_TRANSR + || other->op_type == OP_TRANS) + /* Mark the op as being unbindable with =~ */ + other->op_flags |= OPf_SPECIAL; + + other->op_folded = 1; + return other; + } + else { /* Elide the rhs, since the outcome is entirely determined by * the (constant) lhs */ - /* check for C, or C */ - const OP *o2 = other; - if ( ! (o2->op_type == OP_LIST - && (( o2 = cUNOPx(o2)->op_first)) - && o2->op_type == OP_PUSHMARK - && (( o2 = OpSIBLING(o2))) ) - ) - o2 = other; - if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV - || o2->op_type == OP_PADHV) - && o2->op_private & OPpLVAL_INTRO - && !(o2->op_private & OPpPAD_STATE)) - { + /* check for C, or C */ + const OP *o2 = other; + if ( ! (o2->op_type == OP_LIST + && (( o2 = cUNOPx(o2)->op_first)) + && o2->op_type == OP_PUSHMARK + && (( o2 = OpSIBLING(o2))) ) + ) + o2 = other; + if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV + || o2->op_type == OP_PADHV) + && o2->op_private & OPpLVAL_INTRO + && !(o2->op_private & OPpPAD_STATE)) + { Perl_croak(aTHX_ "This use of my() in false conditional is " "no longer allowed"); - } + } - *otherp = NULL; - if (cstop->op_type == OP_CONST) - cstop->op_private |= OPpCONST_SHORTCIRCUIT; + *otherp = NULL; + if (cstop->op_type == OP_CONST) + cstop->op_private |= OPpCONST_SHORTCIRCUIT; op_free(other); - return first; - } + return first; + } } else if ((first->op_flags & OPf_KIDS) && type != OP_DOR - && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ + && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { - const OP * const k1 = ((UNOP*)first)->op_first; - const OP * const k2 = OpSIBLING(k1); - OPCODE warnop = 0; - switch (first->op_type) - { - case OP_NULL: - if (k2 && k2->op_type == OP_READLINE - && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) - { - warnop = k2->op_type; - } - break; - - case OP_SASSIGN: - if (k1->op_type == OP_READDIR - || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + const OP * const k1 = ((UNOP*)first)->op_first; + const OP * const k2 = OpSIBLING(k1); + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + { + warnop = k2->op_type; + } + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH || k1->op_type == OP_AEACH) - { - warnop = ((k1->op_type == OP_NULL) - ? (OPCODE)k1->op_targ : k1->op_type); - } - break; - } - if (warnop) { - const line_t oldline = CopLINE(PL_curcop); + { + warnop = ((k1->op_type == OP_NULL) + ? (OPCODE)k1->op_targ : k1->op_type); + } + break; + } + if (warnop) { + const line_t oldline = CopLINE(PL_curcop); /* This ensures that warnings are reported at the first line of the construction, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Value of %s%s can be \"0\"; test with defined()", - PL_op_desc[warnop], - ((warnop == OP_READLINE || warnop == OP_GLOB) - ? " construct" : "() operator")); - CopLINE_set(PL_curcop, oldline); - } + CopLINE_set(PL_curcop, PL_parser->copline); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Value of %s%s can be \"0\"; test with defined()", + PL_op_desc[warnop], + ((warnop == OP_READLINE || warnop == OP_GLOB) + ? " construct" : "() operator")); + CopLINE_set(PL_curcop, oldline); + } } /* optimize AND and OR ops that have NOTs as children */ @@ -9735,8 +9735,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); o = newUNOP(prepend_not ? OP_NOT : OP_NULL, - PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, - (OP*)logop); + PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, + (OP*)logop); other->op_next = o; return o; @@ -9767,30 +9767,30 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) PERL_ARGS_ASSERT_NEWCONDOP; if (!falseop) - return newLOGOP(OP_AND, 0, first, trueop); + return newLOGOP(OP_AND, 0, first, trueop); if (!trueop) - return newLOGOP(OP_OR, 0, first, falseop); + return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); if ((cstop = search_const(first))) { - /* Left or right arm of the conditional? */ - const bool left = SvTRUE(((SVOP*)cstop)->op_sv); - OP *live = left ? trueop : falseop; - OP *const dead = left ? falseop : trueop; + /* Left or right arm of the conditional? */ + const bool left = SvTRUE(((SVOP*)cstop)->op_sv); + OP *live = left ? trueop : falseop; + OP *const dead = left ? falseop : trueop; if (cstop->op_private & OPpCONST_BARE && - cstop->op_private & OPpCONST_STRICT) { - no_bareword_allowed(cstop); - } + cstop->op_private & OPpCONST_STRICT) { + no_bareword_allowed(cstop); + } op_free(first); op_free(dead); - if (live->op_type == OP_LEAVE) - live = newUNOP(OP_NULL, OPf_SPECIAL, live); - else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST - || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) - /* Mark the op as being unbindable with =~ */ - live->op_flags |= OPf_SPECIAL; - live->op_folded = 1; - return live; + if (live->op_type == OP_LEAVE) + live = newUNOP(OP_NULL, OPf_SPECIAL, live); + else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST + || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) + /* Mark the op as being unbindable with =~ */ + live->op_flags |= OPf_SPECIAL; + live->op_folded = 1; + return live; } logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_flags |= (U8)flags; @@ -9798,7 +9798,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ - logop); + logop); /* establish postfix order */ start = LINKLIST(first); @@ -9917,10 +9917,10 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) right->op_next = flop; range->op_targ = - pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); flip->op_targ = - pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); SvPADTMP_on(PAD_SV(flip->op_targ)); @@ -9929,13 +9929,13 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) /* check barewords before they might be optimized aways */ if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT) - no_bareword_allowed(left); + no_bareword_allowed(left); if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT) - no_bareword_allowed(right); + no_bareword_allowed(right); flip->op_next = o; if (!flip->op_private || !flop->op_private) - LINKLIST(o); /* blow off optimizer unless constant */ + LINKLIST(o); /* blow off optimizer unless constant */ return o; } @@ -9962,78 +9962,78 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - block->op_type == OP_NULL; + block->op_type == OP_NULL; PERL_UNUSED_ARG(debuggable); if (expr) { - if (once && ( - (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) - || ( expr->op_type == OP_NOT - && cUNOPx(expr)->op_first->op_type == OP_CONST - && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) - ) - )) - /* Return the block now, so that S_new_logop does not try to - fold it away. */ + if (once && ( + (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + || ( expr->op_type == OP_NOT + && cUNOPx(expr)->op_first->op_type == OP_CONST + && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) + ) + )) + /* Return the block now, so that S_new_logop does not try to + fold it away. */ { op_free(expr); return block; /* do {} while 0 does once */ } - if (expr->op_type == OP_READLINE - || expr->op_type == OP_READDIR - || expr->op_type == OP_GLOB - || expr->op_type == OP_EACH || expr->op_type == OP_AEACH - || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { - expr = newUNOP(OP_DEFINED, 0, - newASSIGNOP(0, newDEFSVOP(), 0, expr) ); - } else if (expr->op_flags & OPf_KIDS) { - const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = k1 ? OpSIBLING(k1) : NULL; - switch (expr->op_type) { - case OP_NULL: - if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) - && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) - expr = newUNOP(OP_DEFINED, 0, expr); - break; - - case OP_SASSIGN: - if (k1 && (k1->op_type == OP_READDIR - || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + if (expr->op_type == OP_READLINE + || expr->op_type == OP_READDIR + || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr->op_flags & OPf_KIDS) { + const OP * const k1 = ((UNOP*)expr)->op_first; + const OP * const k2 = k1 ? OpSIBLING(k1) : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1 && (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH || k1->op_type == OP_AEACH)) - expr = newUNOP(OP_DEFINED, 0, expr); - break; - } - } + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } + } } /* if block is null, the next op_append_elem() would put UNSTACK, a scalar * op, in listop. This is wrong. [perl #27024] */ if (!block) - block = newOP(OP_NULL, 0); + block = newOP(OP_NULL, 0); listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); o = new_logop(OP_AND, 0, &expr, &listop); if (once) { - ASSUME(listop); + ASSUME(listop); } if (listop) - ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); + ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) { - assert(cUNOPo->op_first->op_type == OP_AND - || cUNOPo->op_first->op_type == OP_OR); - o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); + o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; } if (o == listop) - o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ + o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ o->op_flags |= flags; o = op_scope(o); @@ -10067,7 +10067,7 @@ loop body to be enclosed in its own scope. OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, - OP *expr, OP *block, OP *cont, I32 has_my) + OP *expr, OP *block, OP *cont, I32 has_my) { OP *redo; OP *next = NULL; @@ -10078,50 +10078,50 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, PERL_UNUSED_ARG(debuggable); if (expr) { - if (expr->op_type == OP_READLINE + if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB - || expr->op_type == OP_EACH || expr->op_type == OP_AEACH - || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { - expr = newUNOP(OP_DEFINED, 0, - newASSIGNOP(0, newDEFSVOP(), 0, expr) ); - } else if (expr->op_flags & OPf_KIDS) { - const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL; - switch (expr->op_type) { - case OP_NULL: - if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) - && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) - expr = newUNOP(OP_DEFINED, 0, expr); - break; - - case OP_SASSIGN: - if (k1 && (k1->op_type == OP_READDIR - || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } else if (expr->op_flags & OPf_KIDS) { + const OP * const k1 = ((UNOP*)expr)->op_first; + const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1 && (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH || k1->op_type == OP_AEACH)) - expr = newUNOP(OP_DEFINED, 0, expr); - break; - } - } + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } + } } if (!block) - block = newOP(OP_NULL, 0); + block = newOP(OP_NULL, 0); else if (cont || has_my) { - block = op_scope(block); + block = op_scope(block); } if (cont) { - next = LINKLIST(cont); + next = LINKLIST(cont); } if (expr) { - OP * const unstack = newOP(OP_UNSTACK, 0); - if (!next) - next = unstack; - cont = op_append_elem(OP_LINESEQ, cont, unstack); + OP * const unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = op_append_elem(OP_LINESEQ, cont, unstack); } assert(block); @@ -10130,24 +10130,24 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, redo = LINKLIST(listop); if (expr) { - scalar(listop); - o = new_logop(OP_AND, 0, &expr, &listop); - if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { - op_free((OP*)loop); - return expr; /* listop already freed by new_logop */ - } - if (listop) - ((LISTOP*)listop)->op_last->op_next = - (o == listop ? redo : LINKLIST(o)); + scalar(listop); + o = new_logop(OP_AND, 0, &expr, &listop); + if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { + op_free((OP*)loop); + return expr; /* listop already freed by new_logop */ + } + if (listop) + ((LISTOP*)listop)->op_last->op_next = + (o == listop ? redo : LINKLIST(o)); } else - o = listop; + o = listop; if (!loop) { - NewOp(1101,loop,1,LOOP); + NewOp(1101,loop,1,LOOP); OpTYPE_set(loop, OP_ENTERLOOP); - loop->op_private = 0; - loop->op_next = (OP*)loop; + loop->op_private = 0; + loop->op_next = (OP*)loop; } o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); @@ -10157,9 +10157,9 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, o->op_private |= loopflags; if (next) - loop->op_nextop = next; + loop->op_nextop = next; else - loop->op_nextop = o; + loop->op_nextop = o; o->op_flags |= flags; o->op_private |= (flags >> 8); @@ -10201,77 +10201,77 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PERL_ARGS_ASSERT_NEWFOROP; if (sv) { - if (sv->op_type == OP_RV2SV) { /* symbol table variable */ - iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ + if (sv->op_type == OP_RV2SV) { /* symbol table variable */ + iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ OpTYPE_set(sv, OP_RV2GV); - /* The op_type check is needed to prevent a possible segfault - * if the loop variable is undeclared and 'strict vars' is in - * effect. This is illegal but is nonetheless parsed, so we - * may reach this point with an OP_CONST where we're expecting - * an OP_GV. - */ - if (cUNOPx(sv)->op_first->op_type == OP_GV - && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) - iterpflags |= OPpITER_DEF; - } - else if (sv->op_type == OP_PADSV) { /* private variable */ - iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ - padoff = sv->op_targ; + /* The op_type check is needed to prevent a possible segfault + * if the loop variable is undeclared and 'strict vars' is in + * effect. This is illegal but is nonetheless parsed, so we + * may reach this point with an OP_CONST where we're expecting + * an OP_GV. + */ + if (cUNOPx(sv)->op_first->op_type == OP_GV + && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) + iterpflags |= OPpITER_DEF; + } + else if (sv->op_type == OP_PADSV) { /* private variable */ + iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ + padoff = sv->op_targ; sv->op_targ = 0; op_free(sv); - sv = NULL; - PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); - } - else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) - NOOP; - else - Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); - if (padoff) { - PADNAME * const pn = PAD_COMPNAME(padoff); - const char * const name = PadnamePV(pn); - - if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_') - iterpflags |= OPpITER_DEF; - } + sv = NULL; + PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); + } + else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) + NOOP; + else + Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); + if (padoff) { + PADNAME * const pn = PAD_COMPNAME(padoff); + const char * const name = PadnamePV(pn); + + if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_') + iterpflags |= OPpITER_DEF; + } } else { - sv = newGVOP(OP_GV, 0, PL_defgv); - iterpflags |= OPpITER_DEF; + sv = newGVOP(OP_GV, 0, PL_defgv); + iterpflags |= OPpITER_DEF; } if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { - expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); - iterflags |= OPf_STACKED; + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); + iterflags |= OPf_STACKED; } else if (expr->op_type == OP_NULL && (expr->op_flags & OPf_KIDS) && ((BINOP*)expr)->op_first->op_type == OP_FLOP) { - /* Basically turn for($x..$y) into the same as for($x,$y), but we - * set the STACKED flag to indicate that these values are to be - * treated as min/max values by 'pp_enteriter'. - */ - const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; - LOGOP* const range = (LOGOP*) flip->op_first; - OP* const left = range->op_first; - OP* const right = OpSIBLING(left); - LISTOP* listop; - - range->op_flags &= ~OPf_KIDS; + /* Basically turn for($x..$y) into the same as for($x,$y), but we + * set the STACKED flag to indicate that these values are to be + * treated as min/max values by 'pp_enteriter'. + */ + const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; + LOGOP* const range = (LOGOP*) flip->op_first; + OP* const left = range->op_first; + OP* const right = OpSIBLING(left); + LISTOP* listop; + + range->op_flags &= ~OPf_KIDS; /* detach range's children */ op_sibling_splice((OP*)range, NULL, -1, NULL); - listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); - listop->op_first->op_next = range->op_next; - left->op_next = range->op_other; - right->op_next = (OP*)listop; - listop->op_next = listop->op_first; + listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); + listop->op_first->op_next = range->op_next; + left->op_next = range->op_other; + right->op_next = (OP*)listop; + listop->op_next = listop->op_first; - op_free(expr); - expr = (OP*)(listop); + op_free(expr); + expr = (OP*)(listop); op_null(expr); - iterflags |= OPf_STACKED; + iterflags |= OPf_STACKED; } else { expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); @@ -10292,18 +10292,18 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER)) { /* no space; allocate new op */ - LOOP *tmp; - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LISTOP); + LOOP *tmp; + NewOp(1234,tmp,1,LOOP); + Copy(loop,tmp,1,LISTOP); assert(loop->op_last->op_sibparent == (OP*)loop); OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */ - S_op_destroy(aTHX_ (OP*)loop); - loop = tmp; + S_op_destroy(aTHX_ (OP*)loop); + loop = tmp; } else if (!loop->op_slabbed) { /* loop was malloc()ed */ - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); OpLASTSIB_set(loop->op_last, (OP*)loop); } loop->op_targ = padoff; @@ -10330,37 +10330,37 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); if (type != OP_GOTO) { - /* "last()" means "last" */ - if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { - o = newOP(type, OPf_SPECIAL); - } + /* "last()" means "last" */ + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { + o = newOP(type, OPf_SPECIAL); + } } else { - /* Check whether it's going to be a goto &function */ - if (label->op_type == OP_ENTERSUB - && !(label->op_flags & OPf_STACKED)) - label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); + /* Check whether it's going to be a goto &function */ + if (label->op_type == OP_ENTERSUB + && !(label->op_flags & OPf_STACKED)) + label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); } /* Check for a constant argument */ if (label->op_type == OP_CONST) { - SV * const sv = ((SVOP *)label)->op_sv; - STRLEN l; - const char *s = SvPV_const(sv,l); - if (l == strlen(s)) { - o = newPVOP(type, - SvUTF8(((SVOP*)label)->op_sv), - savesharedpv( - SvPV_nolen_const(((SVOP*)label)->op_sv))); - } + SV * const sv = ((SVOP *)label)->op_sv; + STRLEN l; + const char *s = SvPV_const(sv,l); + if (l == strlen(s)) { + o = newPVOP(type, + SvUTF8(((SVOP*)label)->op_sv), + savesharedpv( + SvPV_nolen_const(((SVOP*)label)->op_sv))); + } } /* If we have already created an op, we do not need the label. */ if (o) - op_free(label); + op_free(label); else o = newUNOP(type, OPf_STACKED, label); PL_hints |= HINT_BLOCK_SCOPE; @@ -10379,7 +10379,7 @@ S_ref_array_or_hash(pTHX_ OP *cond) || cond->op_type == OP_RV2HV || cond->op_type == OP_PADHV)) - return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); + return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); else if(cond && (cond->op_type == OP_ASLICE @@ -10387,16 +10387,16 @@ S_ref_array_or_hash(pTHX_ OP *cond) || cond->op_type == OP_HSLICE || cond->op_type == OP_KVHSLICE)) { - /* anonlist now needs a list from this op, was previously used in - * scalar context */ - cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); - cond->op_flags |= OPf_WANT_LIST; + /* anonlist now needs a list from this op, was previously used in + * scalar context */ + cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); + cond->op_flags |= OPf_WANT_LIST; - return newANONLIST(op_lvalue(cond, OP_ANONLIST)); + return newANONLIST(op_lvalue(cond, OP_ANONLIST)); } else - return cond; + return cond; } /* These construct the optree fragments representing given() @@ -10411,8 +10411,8 @@ S_ref_array_or_hash(pTHX_ OP *cond) STATIC OP * S_newGIVWHENOP(pTHX_ OP *cond, OP *block, - I32 enter_opcode, I32 leave_opcode, - PADOFFSET entertarg) + I32 enter_opcode, I32 leave_opcode, + PADOFFSET entertarg) { LOGOP *enterop; OP *o; @@ -10430,20 +10430,20 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, /* prepend cond if we have one */ op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); - o->op_next = LINKLIST(cond); - cond->op_next = (OP *) enterop; + o->op_next = LINKLIST(cond); + cond->op_next = (OP *) enterop; } else { - /* This is a default {} block */ - enterop->op_flags |= OPf_SPECIAL; - o ->op_flags |= OPf_SPECIAL; + /* This is a default {} block */ + enterop->op_flags |= OPf_SPECIAL; + o ->op_flags |= OPf_SPECIAL; - o->op_next = (OP *) enterop; + o->op_next = (OP *) enterop; } CHECKOP(enter_opcode, enterop); /* Currently does nothing, since - entergiven and enterwhen both - use ck_null() */ + entergiven and enterwhen both + use ck_null() */ enterop->op_next = LINKLIST(block); block->op_next = enterop->op_other = o; @@ -10471,74 +10471,74 @@ S_looks_like_bool(pTHX_ const OP *o) PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { - case OP_OR: - case OP_DOR: - return looks_like_bool(cLOGOPo->op_first); + case OP_OR: + case OP_DOR: + return looks_like_bool(cLOGOPo->op_first); - case OP_AND: + case OP_AND: { OP* sibl = OpSIBLING(cLOGOPo->op_first); ASSUME(sibl); - return ( - looks_like_bool(cLOGOPo->op_first) - && looks_like_bool(sibl)); + return ( + looks_like_bool(cLOGOPo->op_first) + && looks_like_bool(sibl)); } - case OP_NULL: - case OP_SCALAR: - return ( - o->op_flags & OPf_KIDS - && looks_like_bool(cUNOPo->op_first)); + case OP_NULL: + case OP_SCALAR: + return ( + o->op_flags & OPf_KIDS + && looks_like_bool(cUNOPo->op_first)); - case OP_ENTERSUB: + case OP_ENTERSUB: - case OP_NOT: case OP_XOR: + case OP_NOT: case OP_XOR: - case OP_EQ: case OP_NE: case OP_LT: - case OP_GT: case OP_LE: case OP_GE: + case OP_EQ: case OP_NE: case OP_LT: + case OP_GT: case OP_LE: case OP_GE: - case OP_I_EQ: case OP_I_NE: case OP_I_LT: - case OP_I_GT: case OP_I_LE: case OP_I_GE: + case OP_I_EQ: case OP_I_NE: case OP_I_LT: + case OP_I_GT: case OP_I_LE: case OP_I_GE: - case OP_SEQ: case OP_SNE: case OP_SLT: - case OP_SGT: case OP_SLE: case OP_SGE: + case OP_SEQ: case OP_SNE: case OP_SLT: + case OP_SGT: case OP_SLE: case OP_SGE: - case OP_SMARTMATCH: + case OP_SMARTMATCH: - case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: - case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: - case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: - case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: - case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: - case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: - case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: - case OP_FTTEXT: case OP_FTBINARY: + case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: + case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: + case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: + case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: + case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: + case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: + case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: + case OP_FTTEXT: case OP_FTBINARY: - case OP_DEFINED: case OP_EXISTS: - case OP_MATCH: case OP_EOF: + case OP_DEFINED: case OP_EXISTS: + case OP_MATCH: case OP_EOF: - case OP_FLOP: + case OP_FLOP: - return TRUE; + return TRUE; - case OP_INDEX: - case OP_RINDEX: + case OP_INDEX: + case OP_RINDEX: /* optimised-away (index() != -1) or similar comparison */ if (o->op_private & OPpTRUEBOOL) return TRUE; return FALSE; - case OP_CONST: - /* Detect comparisons that have been optimized away */ - if (cSVOPo->op_sv == &PL_sv_yes - || cSVOPo->op_sv == &PL_sv_no) + case OP_CONST: + /* Detect comparisons that have been optimized away */ + if (cSVOPo->op_sv == &PL_sv_yes + || cSVOPo->op_sv == &PL_sv_no) - return TRUE; - else - return FALSE; - /* FALLTHROUGH */ - default: - return FALSE; + return TRUE; + else + return FALSE; + /* FALLTHROUGH */ + default: + return FALSE; } } @@ -10563,10 +10563,10 @@ Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) assert(!defsv_off); return newGIVWHENOP( - ref_array_or_hash(cond), - block, - OP_ENTERGIVEN, OP_LEAVEGIVEN, - 0); + ref_array_or_hash(cond), + block, + OP_ENTERGIVEN, OP_LEAVEGIVEN, + 0); } /* @@ -10591,11 +10591,11 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) PERL_ARGS_ASSERT_NEWWHENOP; if (cond_llb) - cond_op = cond; + cond_op = cond; else { - cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, - newDEFSVOP(), - scalar(ref_array_or_hash(cond))); + cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, + newDEFSVOP(), + scalar(ref_array_or_hash(cond))); } return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); @@ -10606,76 +10606,76 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, - const STRLEN len, const U32 flags) + const STRLEN len, const U32 flags) { SV *name = NULL, *msg; const char * cvp = SvROK(cv) - ? SvTYPE(SvRV_const(cv)) == SVt_PVCV - ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) - : "" - : CvPROTO(cv); + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; if (p == NULL && cvp == NULL) - return; + return; if (!ckWARN_d(WARN_PROTOTYPE)) - return; + return; if (p && cvp) { - p = S_strip_spaces(aTHX_ p, &plen); - cvp = S_strip_spaces(aTHX_ cvp, &clen); - if ((flags & SVf_UTF8) == SvUTF8(cv)) { - if (plen == clen && memEQ(cvp, p, plen)) - return; - } else { - if (flags & SVf_UTF8) { - if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) - return; + p = S_strip_spaces(aTHX_ p, &plen); + cvp = S_strip_spaces(aTHX_ cvp, &clen); + if ((flags & SVf_UTF8) == SvUTF8(cv)) { + if (plen == clen && memEQ(cvp, p, plen)) + return; + } else { + if (flags & SVf_UTF8) { + if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) + return; } - else { - if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) - return; - } - } + else { + if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) + return; + } + } } msg = sv_newmortal(); if (gv) { - if (isGV(gv)) - gv_efullname3(name = sv_newmortal(), gv, NULL); - else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') - name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); - else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { - name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); - sv_catpvs(name, "::"); - if (SvROK(gv)) { - assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); - assert (CvNAMED(SvRV_const(gv))); - sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); - } - else sv_catsv(name, (SV *)gv); - } - else name = (SV *)gv; + if (isGV(gv)) + gv_efullname3(name = sv_newmortal(), gv, NULL); + else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') + name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } + else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); + Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); if (cvp) - Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", - UTF8fARG(SvUTF8(cv),clen,cvp) - ); + Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", + UTF8fARG(SvUTF8(cv),clen,cvp) + ); else - sv_catpvs(msg, ": none"); + sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) - Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); + Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); else - sv_catpvs(msg, "none"); + sv_catpvs(msg, "none"); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg)); } @@ -10701,9 +10701,9 @@ Perl_cv_const_sv(const CV *const cv) { SV *sv; if (!cv) - return NULL; + return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) - return NULL; + return NULL; sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; return sv; @@ -10713,7 +10713,7 @@ SV * Perl_cv_const_sv_or_av(const CV * const cv) { if (!cv) - return NULL; + return NULL; if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; @@ -10743,87 +10743,87 @@ S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex) assert(cv); for (; o; o = o->op_next) { - const OPCODE type = o->op_type; - - if (type == OP_NEXTSTATE || type == OP_LINESEQ - || type == OP_NULL - || type == OP_PUSHMARK) - continue; - if (type == OP_DBSTATE) - continue; - if (type == OP_LEAVESUB) - break; - if (sv) - return NULL; - if (type == OP_CONST && cSVOPo->op_sv) - sv = cSVOPo->op_sv; - else if (type == OP_UNDEF && !o->op_private) { - sv = newSV(0); - SAVEFREESV(sv); - } - else if (allow_lex && type == OP_PADSV) { - if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) - { - sv = &PL_sv_undef; /* an arbitrary non-null value */ - padsv = TRUE; - } - else - return NULL; - } - else { - return NULL; - } + const OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_LINESEQ + || type == OP_NULL + || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + if (type == OP_LEAVESUB) + break; + if (sv) + return NULL; + if (type == OP_CONST && cSVOPo->op_sv) + sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } + else if (allow_lex && type == OP_PADSV) { + if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) + { + sv = &PL_sv_undef; /* an arbitrary non-null value */ + padsv = TRUE; + } + else + return NULL; + } + else { + return NULL; + } } if (padsv) { - CvCONST_on(cv); - return NULL; + CvCONST_on(cv); + return NULL; } return sv; } static void S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, - PADNAME * const name, SV ** const const_svp) + PADNAME * const name, SV ** const const_svp) { assert (cv); assert (o || name); assert (const_svp); if (!block) { - if (CvFLAGS(PL_compcv)) { - /* might have had built-in attrs applied */ - const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); - if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl - && ckWARN(WARN_MISC)) - { - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); - SvREFCNT_inc_simple_void_NN(PL_compcv); - } - CvFLAGS(cv) |= - (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS - & ~(CVf_LVALUE * pureperl)); - } - return; + if (CvFLAGS(PL_compcv)) { + /* might have had built-in attrs applied */ + const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); + if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl + && ckWARN(WARN_MISC)) + { + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); + SvREFCNT_inc_simple_void_NN(PL_compcv); + } + CvFLAGS(cv) |= + (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS + & ~(CVf_LVALUE * pureperl)); + } + return; } /* redundant check for speed: */ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - SV *namesv = o - ? cSVOPo->op_sv - : sv_2mortal(newSVpvn_utf8( - PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) - )); - if (PL_parser && PL_parser->copline != NOLINE) + const line_t oldline = CopLINE(PL_curcop); + SV *namesv = o + ? cSVOPo->op_sv + : sv_2mortal(newSVpvn_utf8( + PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) + )); + if (PL_parser && PL_parser->copline != NOLINE) /* This ensures that warnings are reported at the first line of a redefinition, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - report_redefined_cv(namesv, cv, const_svp); - SvREFCNT_inc_simple_void_NN(PL_compcv); - CopLINE_set(PL_curcop, oldline); + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + report_redefined_cv(namesv, cv, const_svp); + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); } SAVEFREESV(cv); return; @@ -10860,31 +10860,31 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) need to look in CvOUTSIDE and find the pad belonging to the enclos- ing sub. And then we need to dig deeper if this is a lexical from outside, as in: - my sub foo; sub { sub foo { } } + my sub foo; sub { sub foo { } } */ redo: name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax]; if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) { - pax = PARENT_PAD_INDEX(name); - outcv = CvOUTSIDE(outcv); - assert(outcv); - goto redo; + pax = PARENT_PAD_INDEX(name); + outcv = CvOUTSIDE(outcv); + assert(outcv); + goto redo; } svspot = - &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) - [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; + &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) + [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; spot = (CV **)svspot; if (!(PL_parser && PL_parser->error_count)) move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0); if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } else - ps = NULL; + ps = NULL; if (proto) SAVEFREEOP(proto); @@ -10892,53 +10892,53 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREEOP(attrs); if (PL_parser && PL_parser->error_count) { - op_free(block); - SvREFCNT_dec(PL_compcv); - PL_compcv = 0; - goto done; + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = 0; + goto done; } if (CvDEPTH(outcv) && CvCLONE(compcv)) { - cv = *spot; - svspot = (SV **)(spot = &clonee); + cv = *spot; + svspot = (SV **)(spot = &clonee); } else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) - cv = *spot; + cv = *spot; else { - assert (SvTYPE(*spot) == SVt_PVCV); - if (CvNAMED(*spot)) - hek = CvNAME_HEK(*spot); - else { - U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); - CvNAME_HEK_set(*spot, hek = - share_hek( - PadnamePV(name)+1, - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), - hash - ) - ); - CvLEXICAL_on(*spot); - } - cv = PadnamePROTOCV(name); - svspot = (SV **)(spot = &PadnamePROTOCV(name)); + assert (SvTYPE(*spot) == SVt_PVCV); + if (CvNAMED(*spot)) + hek = CvNAME_HEK(*spot); + else { + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + CvNAME_HEK_set(*spot, hek = + share_hek( + PadnamePV(name)+1, + (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + hash + ) + ); + CvLEXICAL_on(*spot); + } + cv = PadnamePROTOCV(name); + svspot = (SV **)(spot = &PadnamePROTOCV(name)); } if (block) { - /* This makes sub {}; work as expected. */ - if (block->op_type == OP_STUB) { - const line_t l = PL_parser->copline; - op_free(block); - block = newSTATEOP(0, NULL, 0); - PL_parser->copline = l; - } - block = CvLVALUE(compcv) - || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) - ? newUNOP(OP_LEAVESUBLV, 0, - op_lvalue(scalarseq(block), OP_LEAVESUBLV)) - : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - start = LINKLIST(block); - block->op_next = 0; + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(scalarseq(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + start = LINKLIST(block); + block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(compcv)) const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); else @@ -10957,49 +10957,49 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len, ps_utf8); - /* already defined? */ - if (exists) { - S_already_defined(aTHX_ cv, block, NULL, name, &const_sv); + /* already defined? */ + if (exists) { + S_already_defined(aTHX_ cv, block, NULL, name, &const_sv); if (block) - cv = NULL; - else { - if (attrs) + cv = NULL; + else { + if (attrs) goto attrs; - /* just a "sub foo;" when &foo is already defined */ - SAVEFREESV(compcv); - goto done; - } - } - else if (CvDEPTH(outcv) && CvCLONE(compcv)) { - cv = NULL; - reusable = TRUE; - } + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(compcv); + goto done; + } + } + else if (CvDEPTH(outcv) && CvCLONE(compcv)) { + cv = NULL; + reusable = TRUE; + } } if (const_sv) { - SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) |= SVs_PADTMP; - if (cv) { - assert(!CvROOT(cv) && !CvCONST(cv)); - cv_forget_slab(cv); - } - else { - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); - *spot = cv; - } + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); + } + else { + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + *spot = cv; + } SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ - CvXSUBANY(cv).any_ptr = const_sv; - CvXSUB(cv) = const_sv_xsub; - CvCONST_on(cv); - CvISXSUB_on(cv); - PoisonPADLIST(cv); - CvFLAGS(cv) |= CvMETHOD(compcv); - op_free(block); - SvREFCNT_dec(compcv); - PL_compcv = NULL; - goto setname; + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(compcv); + op_free(block); + SvREFCNT_dec(compcv); + PL_compcv = NULL; + goto setname; } /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to @@ -11009,72 +11009,72 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) the package sub. So check PadnameOUTER(name) too. */ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { - assert(!CvWEAKOUTSIDE(compcv)); - SvREFCNT_dec(CvOUTSIDE(compcv)); - CvWEAKOUTSIDE_on(compcv); + assert(!CvWEAKOUTSIDE(compcv)); + SvREFCNT_dec(CvOUTSIDE(compcv)); + CvWEAKOUTSIDE_on(compcv); } /* XXX else do we have a circular reference? */ if (cv) { /* must reuse cv in case stub is referenced elsewhere */ - /* transfer PL_compcv to cv */ - if (block) { + /* transfer PL_compcv to cv */ + if (block) { bool free_file = CvFILE(cv) && CvDYNFILE(cv); - cv_flags_t preserved_flags = - CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); - PADLIST *const temp_padl = CvPADLIST(cv); - CV *const temp_cv = CvOUTSIDE(cv); - const cv_flags_t other_flags = - CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); - OP * const cvstart = CvSTART(cv); - - SvPOK_off(cv); - CvFLAGS(cv) = - CvFLAGS(compcv) | preserved_flags; - CvOUTSIDE(cv) = CvOUTSIDE(compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); - CvPADLIST_set(cv, CvPADLIST(compcv)); - CvOUTSIDE(compcv) = temp_cv; - CvPADLIST_set(compcv, temp_padl); - CvSTART(cv) = CvSTART(compcv); - CvSTART(compcv) = cvstart; - CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); - CvFLAGS(compcv) |= other_flags; - - if (free_file) { - Safefree(CvFILE(cv)); - CvFILE(cv) = NULL; - } - - /* inner references to compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); - if (PERLDB_INTER)/* Advice debugger on the new sub. */ + cv_flags_t preserved_flags = + CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); + PADLIST *const temp_padl = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + SvPOK_off(cv); + CvFLAGS(cv) = + CvFLAGS(compcv) | preserved_flags; + CvOUTSIDE(cv) = CvOUTSIDE(compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); + CvPADLIST_set(cv, CvPADLIST(compcv)); + CvOUTSIDE(compcv) = temp_cv; + CvPADLIST_set(compcv, temp_padl); + CvSTART(cv) = CvSTART(compcv); + CvSTART(compcv) = cvstart; + CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(compcv) |= other_flags; + + if (free_file) { + Safefree(CvFILE(cv)); + CvFILE(cv) = NULL; + } + + /* inner references to compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; - } - else { - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); - } - /* ... before we throw it away */ - SvREFCNT_dec(compcv); - PL_compcv = compcv = cv; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(compcv); + PL_compcv = compcv = cv; } else { - cv = compcv; - *spot = cv; + cv = compcv; + *spot = cv; } setname: CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - if (hek) (void)share_hek_hek(hek); - else { - U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); - hek = share_hek(PadnamePV(name)+1, - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), - hash); - } - CvNAME_HEK_set(cv, hek); + if (hek) (void)share_hek_hek(hek); + else { + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, + (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) @@ -11086,7 +11086,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH_set(cv, PL_curstash); if (ps) { - sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if (ps_utf8) SvUTF8_on(MUTABLE_SV(cv)); } @@ -11111,75 +11111,75 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) attrs: if (attrs) { - /* Need to do a C. */ - apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); + /* Need to do a C. */ + apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); } if (block) { - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); - GV * const db_postponed = gv_fetchpvs("DB::postponed", - GV_ADDMULTI, SVt_PVHV); - HV *hv; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", - CopFILE(PL_curcop), - (long)PL_subline, - (long)CopLINE(PL_curcop)); - if (HvNAME_HEK(PL_curstash)) { - sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); - sv_catpvs(tmpstr, "::"); - } - else + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = sv_newmortal(); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + if (HvNAME_HEK(PL_curstash)) { + sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); + sv_catpvs(tmpstr, "::"); + } + else sv_setpvs(tmpstr, "__ANON__::"); - sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, - PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); - (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), - SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); - hv = GvHVn(db_postponed); - if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { - CV * const pcv = GvCV(db_postponed); - if (pcv) { - dSP; - PUSHMARK(SP); - XPUSHs(tmpstr); - PUTBACK; - call_sv(MUTABLE_SV(pcv), G_DISCARD); - } - } - } + sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, + PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); + (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), + SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } } clone: if (clonee) { - assert(CvDEPTH(outcv)); - spot = (CV **) - &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; - if (reusable) + assert(CvDEPTH(outcv)); + spot = (CV **) + &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; + if (reusable) cv_clone_into(clonee, *spot); - else *spot = cv_clone(clonee); - SvREFCNT_dec_NN(clonee); - cv = *spot; + else *spot = cv_clone(clonee); + SvREFCNT_dec_NN(clonee); + cv = *spot; } if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { - PADOFFSET depth = CvDEPTH(outcv); - while (--depth) { - SV *oldcv; - svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; - oldcv = *svspot; - *svspot = SvREFCNT_inc_simple_NN(cv); - SvREFCNT_dec(oldcv); - } + PADOFFSET depth = CvDEPTH(outcv); + while (--depth) { + SV *oldcv; + svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; + oldcv = *svspot; + *svspot = SvREFCNT_inc_simple_NN(cv); + SvREFCNT_dec(oldcv); + } } done: if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS if (slab) - Slab_to_ro(slab); + Slab_to_ro(slab); #endif op_free(o); return cv; @@ -11279,7 +11279,7 @@ Like C>, but without attributes. /* _x = extended */ CV * Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, - OP *block, bool o_is_gv) + OP *block, bool o_is_gv) { GV *gv; const char *ps; @@ -11294,12 +11294,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags - = ec ? GV_NOADD_NOINIT : + = ec ? GV_NOADD_NOINIT : (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) - ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; + ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; const char * const name = - o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); bool evanescent = FALSE; @@ -11309,41 +11309,41 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #endif if (o_is_gv) { - gv = (GV*)o; - o = NULL; - has_name = TRUE; + gv = (GV*)o; + o = NULL; + has_name = TRUE; } else if (name) { - /* Try to optimise and avoid creating a GV. Instead, the CV’s name - hek and CvSTASH pointer together can imply the GV. If the name - contains a package name, then GvSTASH(CvGV(cv)) may differ from - CvSTASH, so forego the optimisation if we find any. - Also, we may be called from load_module at run time, so - PL_curstash (which sets CvSTASH) may not point to the stash the - sub is stored in. */ - /* XXX This optimization is currently disabled for packages other - than main, since there was too much CPAN breakage. */ - const I32 flags = - ec ? GV_NOADD_NOINIT - : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)) - || PL_curstash != PL_defstash - || memchr(name, ':', namlen) || memchr(name, '\'', namlen) - ? gv_fetch_flags - : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; - gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); - has_name = TRUE; + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + /* XXX This optimization is currently disabled for packages other + than main, since there was too much CPAN breakage. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)) + || PL_curstash != PL_defstash + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); + has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { - SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", - PL_curstash ? "__ANON__" : "__ANON__::__ANON__", - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); - has_name = TRUE; + SV * const sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", + PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; } else if (PL_curstash) { - gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); - has_name = FALSE; + gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } else { - gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); - has_name = FALSE; + gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } if (!ec) { @@ -11356,12 +11356,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } else - ps = NULL; + ps = NULL; if (o) SAVEFREEOP(o); @@ -11371,29 +11371,29 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SAVEFREEOP(attrs); if (ec) { - op_free(block); + op_free(block); - if (name) + if (name) SvREFCNT_dec(PL_compcv); - else + else cv = PL_compcv; - PL_compcv = 0; - if (name && block) { - const char *s = (char *) my_memrchr(name, ':', namlen); - s = s ? s+1 : name; - if (strEQ(s, "BEGIN")) { - if (PL_in_eval & EVAL_KEEPERR) - Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); - else { + PL_compcv = 0; + if (name && block) { + const char *s = (char *) my_memrchr(name, ':', namlen); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + if (PL_in_eval & EVAL_KEEPERR) + Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); + else { SV * const errsv = ERRSV; - /* force display of errors found but not reported */ - sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); - Perl_croak_nocontext("%" SVf, SVfARG(errsv)); - } - } - } - goto done; + /* force display of errors found but not reported */ + sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); + } + } + } + goto done; } if (!block && SvTYPE(gv) != SVt_PVGV) { @@ -11431,30 +11431,30 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } cv = (!name || (isGV(gv) && GvCVGEN(gv))) - ? NULL - : isGV(gv) - ? GvCV(gv) - : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV - ? (CV *)SvRV(gv) - : NULL; + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; if (block) { - assert(PL_parser); - /* This makes sub {}; work as expected. */ - if (block->op_type == OP_STUB) { - const line_t l = PL_parser->copline; - op_free(block); - block = newSTATEOP(0, NULL, 0); - PL_parser->copline = l; - } - block = CvLVALUE(PL_compcv) - || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) - && (!isGV(gv) || !GvASSUMECV(gv))) - ? newUNOP(OP_LEAVESUBLV, 0, - op_lvalue(scalarseq(block), OP_LEAVESUBLV)) - : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - start = LINKLIST(block); - block->op_next = 0; + assert(PL_parser); + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(PL_compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) + && (!isGV(gv) || !GvASSUMECV(gv))) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(scalarseq(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + start = LINKLIST(block); + block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) const_sv = S_op_const_sv(aTHX_ start, PL_compcv, @@ -11466,36 +11466,36 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv = NULL; if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { - cv_ckproto_len_flags((const CV *)gv, - o ? (const GV *)cSVOPo->op_sv : NULL, ps, - ps_len, ps_utf8|CV_CKPROTO_CURSTASH); - if (SvROK(gv)) { - /* All the other code for sub redefinition warnings expects the - clobbered sub to be a CV. Instead of making all those code - paths more complex, just inline the RV version here. */ - const line_t oldline = CopLINE(PL_curcop); - assert(IN_PERL_COMPILETIME); - if (PL_parser && PL_parser->copline != NOLINE) - /* This ensures that warnings are reported at the first - line of a redefinition, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - - if (ckWARN(WARN_REDEFINE) - || ( ckWARN_d(WARN_REDEFINE) - && ( !const_sv || SvRV(gv) == const_sv - || sv_cmp(SvRV(gv), const_sv) ))) { + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) { assert(cSVOPo); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Constant subroutine %" SVf " redefined", - SVfARG(cSVOPo->op_sv)); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %" SVf " redefined", + SVfARG(cSVOPo->op_sv)); } - SvREFCNT_inc_simple_void_NN(PL_compcv); - CopLINE_set(PL_curcop, oldline); - SvREFCNT_dec(SvRV(gv)); - } + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } } if (cv) { @@ -11507,61 +11507,61 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, */ if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); - /* already defined (or promised)? */ - if (exists || (isGV(gv) && GvASSUMECV(gv))) { - S_already_defined(aTHX_ cv, block, o, NULL, &const_sv); + /* already defined (or promised)? */ + if (exists || (isGV(gv) && GvASSUMECV(gv))) { + S_already_defined(aTHX_ cv, block, o, NULL, &const_sv); if (block) - cv = NULL; - else { - if (attrs) + cv = NULL; + else { + if (attrs) goto attrs; - /* just a "sub foo;" when &foo is already defined */ - SAVEFREESV(PL_compcv); - goto done; - } - } + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(PL_compcv); + goto done; + } + } } if (const_sv) { - SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) |= SVs_PADTMP; - if (cv) { - assert(!CvROOT(cv) && !CvCONST(cv)); - cv_forget_slab(cv); + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ - CvXSUBANY(cv).any_ptr = const_sv; - CvXSUB(cv) = const_sv_xsub; - CvCONST_on(cv); - CvISXSUB_on(cv); - PoisonPADLIST(cv); - CvFLAGS(cv) |= CvMETHOD(PL_compcv); - } - else { - if (isGV(gv) || CvMETHOD(PL_compcv)) { - if (name && isGV(gv)) - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); - assert(cv); - assert(SvREFCNT((SV*)cv) != 0); - CvFLAGS(cv) |= CvMETHOD(PL_compcv); - } - else { - if (!SvROK(gv)) { - SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); - prepare_SV_for_RV((SV *)gv); - SvOK_off((SV *)gv); - SvROK_on(gv); - } - SvRV_set(gv, const_sv); - } - } - op_free(block); - SvREFCNT_dec(PL_compcv); - PL_compcv = NULL; - goto done; + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + else { + if (isGV(gv) || CvMETHOD(PL_compcv)) { + if (name && isGV(gv)) + GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + assert(cv); + assert(SvREFCNT((SV*)cv) != 0); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + goto done; } /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */ @@ -11569,106 +11569,106 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv = NULL; if (cv) { /* must reuse cv if autoloaded */ - /* transfer PL_compcv to cv */ - if (block) { + /* transfer PL_compcv to cv */ + if (block) { bool free_file = CvFILE(cv) && CvDYNFILE(cv); - cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; - PADLIST *const temp_av = CvPADLIST(cv); - CV *const temp_cv = CvOUTSIDE(cv); - const cv_flags_t other_flags = - CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); - OP * const cvstart = CvSTART(cv); - - if (isGV(gv)) { - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); - } - else { - U32 hash; - PERL_HASH(hash, name, namlen); - CvNAME_HEK_set(cv, - share_hek(name, - name_is_utf8 - ? -(SSize_t)namlen - : (SSize_t)namlen, - hash)); - } - - SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs - | CvNAMED(cv); - CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvPADLIST_set(cv,CvPADLIST(PL_compcv)); - CvOUTSIDE(PL_compcv) = temp_cv; - CvPADLIST_set(PL_compcv, temp_av); - CvSTART(cv) = CvSTART(PL_compcv); - CvSTART(PL_compcv) = cvstart; - CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); - CvFLAGS(PL_compcv) |= other_flags; - - if (free_file) { - Safefree(CvFILE(cv)); + cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; + PADLIST *const temp_av = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } + + SvPOK_off(cv); + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvPADLIST_set(cv,CvPADLIST(PL_compcv)); + CvOUTSIDE(PL_compcv) = temp_cv; + CvPADLIST_set(PL_compcv, temp_av); + CvSTART(cv) = CvSTART(PL_compcv); + CvSTART(PL_compcv) = cvstart; + CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(PL_compcv) |= other_flags; + + if (free_file) { + Safefree(CvFILE(cv)); } - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); - /* inner references to PL_compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); - if (PERLDB_INTER)/* Advice debugger on the new sub. */ + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; - } - else { - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); - } - /* ... before we throw it away */ - SvREFCNT_dec(PL_compcv); - PL_compcv = cv; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(PL_compcv); + PL_compcv = cv; } else { - cv = PL_compcv; - if (name && isGV(gv)) { - GvCV_set(gv, cv); - GvCVGEN(gv) = 0; - if (HvENAME_HEK(GvSTASH(gv))) - /* sub Foo::bar { (shift)+1 } */ - gv_method_changed(gv); - } - else if (name) { - if (!SvROK(gv)) { - SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); - prepare_SV_for_RV((SV *)gv); - SvOK_off((SV *)gv); - SvROK_on(gv); - } - SvRV_set(gv, (SV *)cv); - if (HvENAME_HEK(PL_curstash)) - mro_method_changed_in(PL_curstash); - } + cv = PL_compcv; + if (name && isGV(gv)) { + GvCV_set(gv, cv); + GvCVGEN(gv) = 0; + if (HvENAME_HEK(GvSTASH(gv))) + /* sub Foo::bar { (shift)+1 } */ + gv_method_changed(gv); + } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + if (HvENAME_HEK(PL_curstash)) + mro_method_changed_in(PL_curstash); + } } assert(cv); assert(SvREFCNT((SV*)cv) != 0); if (!CvHASGV(cv)) { - if (isGV(gv)) + if (isGV(gv)) CvGV_set(cv, gv); - else { - U32 hash; - PERL_HASH(hash, name, namlen); - CvNAME_HEK_set(cv, share_hek(name, - name_is_utf8 - ? -(SSize_t)namlen - : (SSize_t)namlen, - hash)); - } - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); } if (ps) { - sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } @@ -11693,41 +11693,41 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { - /* Need to do a C. */ - HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) - ? GvSTASH(CvGV(cv)) - : PL_curstash; - if (!name) + /* Need to do a C. */ + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; + if (!name) SAVEFREESV(cv); - apply_attrs(stash, MUTABLE_SV(cv), attrs); - if (!name) + apply_attrs(stash, MUTABLE_SV(cv), attrs); + if (!name) SvREFCNT_inc_simple_void_NN(cv); } if (block && has_name) { - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = cv_name(cv,NULL,0); - GV * const db_postponed = gv_fetchpvs("DB::postponed", - GV_ADDMULTI, SVt_PVHV); - HV *hv; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", - CopFILE(PL_curcop), - (long)PL_subline, - (long)CopLINE(PL_curcop)); - (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), - SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); - hv = GvHVn(db_postponed); - if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { - CV * const pcv = GvCV(db_postponed); - if (pcv) { - dSP; - PUSHMARK(SP); - XPUSHs(tmpstr); - PUTBACK; - call_sv(MUTABLE_SV(pcv), G_DISCARD); - } - } - } + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = cv_name(cv,NULL,0); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), + SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } if (name) { if (PL_parser && PL_parser->error_count) @@ -11742,17 +11742,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, done: assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); if (!evanescent) { #ifdef PERL_DEBUG_READONLY_OPS if (slab) - Slab_to_ro(slab); + Slab_to_ro(slab); #endif if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv))) - pad_add_weakref(cv); + pad_add_weakref(cv); } return cv; } @@ -11785,8 +11785,8 @@ S_clear_special_blocks(pTHX_ const char *const fullname, /* Returns true if the sub has been freed. */ STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, - GV *const gv, - CV *const cv) + GV *const gv, + CV *const cv) { const char *const colon = strrchr(fullname,':'); const char *const name = colon ? colon + 1 : fullname; @@ -11794,68 +11794,68 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; if (*name == 'B') { - if (strEQ(name, "BEGIN")) { - const I32 oldscope = PL_scopestack_ix; + if (strEQ(name, "BEGIN")) { + const I32 oldscope = PL_scopestack_ix; dSP; (void)CvGV(cv); - if (floor) LEAVE_SCOPE(floor); - ENTER; + if (floor) LEAVE_SCOPE(floor); + ENTER; PUSHSTACKi(PERLSI_REQUIRE); - SAVECOPFILE(&PL_compiling); - SAVECOPLINE(&PL_compiling); - SAVEVPTR(PL_curcop); + SAVECOPFILE(&PL_compiling); + SAVECOPLINE(&PL_compiling); + SAVEVPTR(PL_curcop); - DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); - GvCV_set(gv,0); /* cv has been hijacked */ - call_list(oldscope, PL_beginav); + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); + GvCV_set(gv,0); /* cv has been hijacked */ + call_list(oldscope, PL_beginav); POPSTACK; - LEAVE; - return !PL_savebegin; - } - else - return FALSE; + LEAVE; + return !PL_savebegin; + } + else + return FALSE; } else { - if (*name == 'E') { - if (strEQ(name, "END")) { - DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); - } else - return FALSE; - } else if (*name == 'U') { - if (strEQ(name, "UNITCHECK")) { - /* It's never too late to run a unitcheck block */ - Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else if (*name == 'C') { - if (strEQ(name, "CHECK")) { - if (PL_main_start) - /* diag_listed_as: Too late to run %s block */ - Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run CHECK block"); - Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else if (*name == 'I') { - if (strEQ(name, "INIT")) { - if (PL_main_start) - /* diag_listed_as: Too late to run %s block */ - Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run INIT block"); - Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else - return FALSE; - DEBUG_x( dump_sub(gv) ); - (void)CvGV(cv); - GvCV_set(gv,0); /* cv has been hijacked */ - return FALSE; + if (*name == 'E') { + if (strEQ(name, "END")) { + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); + } else + return FALSE; + } else if (*name == 'U') { + if (strEQ(name, "UNITCHECK")) { + /* It's never too late to run a unitcheck block */ + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else + return FALSE; + DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); + GvCV_set(gv,0); /* cv has been hijacked */ + return FALSE; } } @@ -11955,13 +11955,13 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, ENTER; if (IN_PERL_RUNTIME) { - /* at runtime, it's not safe to manipulate PL_curcop: it may be - * an op shared between threads. Use a non-shared COP for our - * dirty work */ - SAVEVPTR(PL_curcop); - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - PL_curcop = &PL_compiling; + /* at runtime, it's not safe to manipulate PL_curcop: it may be + * an op shared between threads. Use a non-shared COP for our + * dirty work */ + SAVEVPTR(PL_curcop); + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + PL_curcop = &PL_compiling; } SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); @@ -11970,8 +11970,8 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { - SAVEGENERICSV(PL_curstash); - PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); + SAVEGENERICSV(PL_curstash); + PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); } /* Protect sv against leakage caused by fatal warnings. */ @@ -11982,11 +11982,11 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ cv = newXS_len_flags(name, len, - sv && SvTYPE(sv) == SVt_PVAV - ? const_av_xsub - : const_sv_xsub, - file ? file : "", "", - &sv, XS_DYNAMIC_FILENAME | flags); + sv && SvTYPE(sv) == SVt_PVAV + ? const_av_xsub + : const_sv_xsub, + file ? file : "", "", + &sv, XS_DYNAMIC_FILENAME | flags); assert(cv); assert(SvREFCNT((SV*)cv) != 0); CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); @@ -12011,14 +12011,14 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) { PERL_ARGS_ASSERT_NEWXS; return newXS_len_flags( - name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 + name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 ); } CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, - const char *const filename, const char *const proto, - U32 flags) + const char *const filename, const char *const proto, + U32 flags) { PERL_ARGS_ASSERT_NEWXS_FLAGS; return newXS_len_flags( @@ -12109,9 +12109,9 @@ ensure that it knows which of these situations applies. CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, - XSUBADDR_t subaddr, const char *const filename, - const char *const proto, SV **const_svp, - U32 flags) + XSUBADDR_t subaddr, const char *const filename, + const char *const proto, SV **const_svp, + U32 flags) { CV *cv; bool interleave = FALSE; @@ -12121,10 +12121,10 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, { GV * const gv = gv_fetchpvn( - name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", - name ? len : PL_curstash ? sizeof("__ANON__") - 1: - sizeof("__ANON__::__ANON__") - 1, - GV_ADDMULTI | flags, SVt_PVCV); + name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + name ? len : PL_curstash ? sizeof("__ANON__") - 1: + sizeof("__ANON__::__ANON__") - 1, + GV_ADDMULTI | flags, SVt_PVCV); if ((cv = (name ? GvCV(gv) : NULL))) { if (GvCVGEN(gv)) { @@ -12160,8 +12160,8 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, gv_method_changed(gv); /* newXS */ } } - assert(cv); - assert(SvREFCNT((SV*)cv) != 0); + assert(cv); + assert(SvREFCNT((SV*)cv) != 0); CvGV_set(cv, gv); if(filename) { @@ -12217,10 +12217,10 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake) GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv))) - gv_method_changed(gv); + gv_method_changed(gv); if (SvFAKE(gv)) { - cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); - SvFAKE_off(cvgv); + cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); + SvFAKE_off(cvgv); } else cvgv = gv; CvGV_set(cv, cvgv); @@ -12239,31 +12239,31 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OP *start; if (PL_parser && PL_parser->error_count) { - op_free(block); - goto finish; + op_free(block); + goto finish; } gv = o - ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) - : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); + ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) + : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); GvMULTI_on(gv); if ((cv = GvFORM(gv))) { - if (ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) - CopLINE_set(PL_curcop, PL_parser->copline); - if (o) { - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); - } else { - /* diag_listed_as: Format %s redefined */ - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Format STDOUT redefined"); - } - CopLINE_set(PL_curcop, oldline); - } - SvREFCNT_dec(cv); + if (ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); + } else { + /* diag_listed_as: Format %s redefined */ + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); } cv = PL_compcv; GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); @@ -12281,7 +12281,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) finish: op_free(o); if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); PL_compiling.cop_seq = 0; } @@ -12309,13 +12309,13 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); OP * anoncode = - newSVOP(OP_ANONCODE, 0, - cv); + newSVOP(OP_ANONCODE, 0, + cv); if (CvANONCONST(cv)) - anoncode = newUNOP(OP_ANONCONST, 0, - op_convert_list(OP_ENTERSUB, - OPf_STACKED|OPf_WANT_SCALAR, - anoncode)); + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); return newUNOP(OP_REFGEN, 0, anoncode); } @@ -12329,17 +12329,17 @@ Perl_oopsAV(pTHX_ OP *o) case OP_PADSV: case OP_PADHV: OpTYPE_set(o, OP_PADAV); - return ref(o, OP_RV2AV); + return ref(o, OP_RV2AV); case OP_RV2SV: case OP_RV2HV: OpTYPE_set(o, OP_RV2AV); - ref(o, OP_RV2AV); - break; + ref(o, OP_RV2AV); + break; default: - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); - break; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); + break; } return o; } @@ -12354,19 +12354,19 @@ Perl_oopsHV(pTHX_ OP *o) case OP_PADSV: case OP_PADAV: OpTYPE_set(o, OP_PADHV); - return ref(o, OP_RV2HV); + return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: OpTYPE_set(o, OP_RV2HV); /* rv2hv steals the bottom bit for its own uses */ o->op_private &= ~OPpARG1_MASK; - ref(o, OP_RV2HV); - break; + ref(o, OP_RV2HV); + break; default: - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); - break; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); + break; } return o; } @@ -12379,10 +12379,10 @@ Perl_newAVREF(pTHX_ OP *o) if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADAV); - return o; + return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { - Perl_croak(aTHX_ "Can't use an array as a reference"); + Perl_croak(aTHX_ "Can't use an array as a reference"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -12391,7 +12391,7 @@ OP * Perl_newGVREF(pTHX_ I32 type, OP *o) { if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) - return newUNOP(OP_NULL, 0, o); + return newUNOP(OP_NULL, 0, o); return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } @@ -12403,10 +12403,10 @@ Perl_newHVREF(pTHX_ OP *o) if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADHV); - return o; + return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { - Perl_croak(aTHX_ "Can't use a hash as a reference"); + Perl_croak(aTHX_ "Can't use a hash as a reference"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -12429,7 +12429,7 @@ Perl_newSVREF(pTHX_ OP *o) if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADSV); scalar(o); - return o; + return o; } return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -12452,39 +12452,39 @@ S_io_hints(pTHX_ OP *o) { #if O_BINARY != 0 || O_TEXT != 0 HV * const table = - PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; if (table) { - SV **svp = hv_fetchs(table, "open_IN", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); + SV **svp = hv_fetchs(table, "open_IN", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ # if O_BINARY != 0 - if (mode & O_BINARY) - o->op_private |= OPpOPEN_IN_RAW; + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; # endif # if O_TEXT != 0 - if (mode & O_TEXT) - o->op_private |= OPpOPEN_IN_CRLF; + if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; # endif - } + } - svp = hv_fetchs(table, "open_OUT", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); + svp = hv_fetchs(table, "open_OUT", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ # if O_BINARY != 0 - if (mode & O_BINARY) - o->op_private |= OPpOPEN_OUT_RAW; + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; # endif # if O_TEXT != 0 - if (mode & O_TEXT) - o->op_private |= OPpOPEN_OUT_CRLF; + if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; # endif - } + } } #else PERL_UNUSED_CONTEXT; @@ -12506,13 +12506,13 @@ Perl_ck_backtick(pTHX_ OP *o) { /* detach rest of siblings from o and its first child */ op_sibling_splice(o, cUNOPo->op_first, -1, NULL); - newop = S_new_entersubop(aTHX_ gv, sibl); + newop = S_new_entersubop(aTHX_ gv, sibl); } else if (!(o->op_flags & OPf_KIDS)) - newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); + newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); if (newop) { - op_free(o); - return newop; + op_free(o); + return newop; } S_io_hints(aTHX_ o); return o; @@ -12526,25 +12526,25 @@ Perl_ck_bitop(pTHX_ OP *o) o->op_private = (U8)(PL_hints & HINT_INTEGER); if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ - && OP_IS_INFIX_BIT(o->op_type)) + && OP_IS_INFIX_BIT(o->op_type)) { - const OP * const left = cBINOPo->op_first; - const OP * const right = OpSIBLING(left); - if ((OP_IS_NUMCOMPARE(left->op_type) && - (left->op_flags & OPf_PARENS) == 0) || - (OP_IS_NUMCOMPARE(right->op_type) && - (right->op_flags & OPf_PARENS) == 0)) - Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), - "Possible precedence problem on bitwise %s operator", - o->op_type == OP_BIT_OR - ||o->op_type == OP_NBIT_OR ? "|" - : o->op_type == OP_BIT_AND - ||o->op_type == OP_NBIT_AND ? "&" - : o->op_type == OP_BIT_XOR - ||o->op_type == OP_NBIT_XOR ? "^" - : o->op_type == OP_SBIT_OR ? "|." - : o->op_type == OP_SBIT_AND ? "&." : "^." - ); + const OP * const left = cBINOPo->op_first; + const OP * const right = OpSIBLING(left); + if ((OP_IS_NUMCOMPARE(left->op_type) && + (left->op_flags & OPf_PARENS) == 0) || + (OP_IS_NUMCOMPARE(right->op_type) && + (right->op_flags & OPf_PARENS) == 0)) + Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %s operator", + o->op_type == OP_BIT_OR + ||o->op_type == OP_NBIT_OR ? "|" + : o->op_type == OP_BIT_AND + ||o->op_type == OP_NBIT_AND ? "&" + : o->op_type == OP_BIT_XOR + ||o->op_type == OP_NBIT_XOR ? "^" + : o->op_type == OP_SBIT_OR ? "|." + : o->op_type == OP_SBIT_AND ? "&." : "^." + ); } return o; } @@ -12555,9 +12555,9 @@ is_dollar_bracket(pTHX_ const OP * const o) const OP *kid; PERL_UNUSED_CONTEXT; return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS - && (kid = cUNOPx(o)->op_first) - && kid->op_type == OP_GV - && strEQ(GvNAME(cGVOPx_gv(kid)), "["); + && (kid = cUNOPx(o)->op_first) + && kid->op_type == OP_GV + && strEQ(GvNAME(cGVOPx_gv(kid)), "["); } /* for lt, gt, le, ge, eq, ne and their i_ variants */ @@ -12581,19 +12581,19 @@ Perl_ck_cmp(pTHX_ OP *o) || o->op_type == OP_I_NE); if (!is_eq && ckWARN(WARN_SYNTAX)) { - const OP *kid = cUNOPo->op_first; - if (kid && + const OP *kid = cUNOPo->op_first; + if (kid && ( - ( is_dollar_bracket(aTHX_ kid) + ( is_dollar_bracket(aTHX_ kid) && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST - ) - || ( kid->op_type == OP_CONST - && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) ) - ) + || ( kid->op_type == OP_CONST + && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) ) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "$[ used in %s (did you mean $] ?)", OP_DESC(o)); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "$[ used in %s (did you mean $] ?)", OP_DESC(o)); } /* convert (index(...) == -1) and variations into @@ -12686,7 +12686,7 @@ Perl_ck_concat(pTHX_ OP *o) /* reuse the padtmp returned by the concat child */ if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && - !(kUNOP->op_first->op_flags & OPf_MOD)) + !(kUNOP->op_first->op_flags & OPf_MOD)) { o->op_flags |= OPf_STACKED; o->op_private |= OPpCONCAT_NESTED; @@ -12701,30 +12701,30 @@ Perl_ck_spair(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SPAIR; if (o->op_flags & OPf_KIDS) { - OP* newop; - OP* kid; + OP* newop; + OP* kid; OP* kidkid; - const OPCODE type = o->op_type; - o = modkids(ck_fun(o), type); - kid = cUNOPo->op_first; - kidkid = kUNOP->op_first; - newop = OpSIBLING(kidkid); - if (newop) { - const OPCODE type = newop->op_type; - if (OpHAS_SIBLING(newop)) - return o; - if (o->op_type == OP_REFGEN - && ( type == OP_RV2CV - || ( !(newop->op_flags & OPf_PARENS) - && ( type == OP_RV2AV || type == OP_PADAV - || type == OP_RV2HV || type == OP_PADHV)))) - NOOP; /* OK (allow srefgen for \@a and \%h) */ - else if (OP_GIMME(newop,0) != G_SCALAR) - return o; - } + const OPCODE type = o->op_type; + o = modkids(ck_fun(o), type); + kid = cUNOPo->op_first; + kidkid = kUNOP->op_first; + newop = OpSIBLING(kidkid); + if (newop) { + const OPCODE type = newop->op_type; + if (OpHAS_SIBLING(newop)) + return o; + if (o->op_type == OP_REFGEN + && ( type == OP_RV2CV + || ( !(newop->op_flags & OPf_PARENS) + && ( type == OP_RV2AV || type == OP_PADAV + || type == OP_RV2HV || type == OP_PADHV)))) + NOOP; /* OK (allow srefgen for \@a and \%h) */ + else if (OP_GIMME(newop,0) != G_SCALAR) + return o; + } /* excise first sibling */ op_sibling_splice(kid, NULL, 1, NULL); - op_free(kidkid); + op_free(kidkid); } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, * and OP_CHOMP into OP_SCHOMP */ @@ -12740,32 +12740,32 @@ Perl_ck_delete(pTHX_ OP *o) o = ck_fun(o); o->op_private = 0; if (o->op_flags & OPf_KIDS) { - OP * const kid = cUNOPo->op_first; - switch (kid->op_type) { - case OP_ASLICE: - o->op_flags |= OPf_SPECIAL; - /* FALLTHROUGH */ - case OP_HSLICE: - o->op_private |= OPpSLICE; - break; - case OP_AELEM: - o->op_flags |= OPf_SPECIAL; - /* FALLTHROUGH */ - case OP_HELEM: - break; - case OP_KVASLICE: + OP * const kid = cUNOPo->op_first; + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALLTHROUGH */ + case OP_HSLICE: + o->op_private |= OPpSLICE; + break; + case OP_AELEM: o->op_flags |= OPf_SPECIAL; /* FALLTHROUGH */ - case OP_KVHSLICE: + case OP_HELEM: + break; + case OP_KVASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALLTHROUGH */ + case OP_KVHSLICE: o->op_private |= OPpKVSLICE; break; - default: - Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " - "element or slice"); - } - if (kid->op_private & OPpLVAL_INTRO) - o->op_private |= OPpLVAL_INTRO; - op_null(kid); + default: + Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " + "element or slice"); + } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; + op_null(kid); } return o; } @@ -12776,17 +12776,17 @@ Perl_ck_eof(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { - OP *kid; - if (cLISTOPo->op_first->op_type == OP_STUB) { - OP * const newop - = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); - op_free(o); - o = newop; - } - o = ck_fun(o); - kid = cLISTOPo->op_first; - if (kid->op_type == OP_RV2GV) - kid->op_private |= OPpALLOW_FAKE; + OP *kid; + if (cLISTOPo->op_first->op_type == OP_STUB) { + OP * const newop + = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + o = newop; + } + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) + kid->op_private |= OPpALLOW_FAKE; } return o; } @@ -12800,57 +12800,57 @@ Perl_ck_eval(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { - SVOP * const kid = (SVOP*)cUNOPo->op_first; - assert(kid); + SVOP * const kid = (SVOP*)cUNOPo->op_first; + assert(kid); - if (o->op_type == OP_ENTERTRY) { - LOGOP *enter; + if (o->op_type == OP_ENTERTRY) { + LOGOP *enter; /* cut whole sibling chain free from o */ op_sibling_splice(o, NULL, -1, NULL); - op_free(o); + op_free(o); enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL); - /* establish postfix order */ - enter->op_next = (OP*)enter; + /* establish postfix order */ + enter->op_next = (OP*)enter; - o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); + o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); OpTYPE_set(o, OP_LEAVETRY); - enter->op_other = o; - return o; - } - else { - scalar((OP*)kid); - S_set_haseval(aTHX); - } + enter->op_other = o; + return o; + } + else { + scalar((OP*)kid); + S_set_haseval(aTHX); + } } else { - const U8 priv = o->op_private; - op_free(o); + const U8 priv = o->op_private; + op_free(o); /* the newUNOP will recursively call ck_eval(), which will handle * all the stuff at the end of this function, like adding * OP_HINTSEVAL */ - return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); + return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { - /* Store a copy of %^H that pp_entereval can pick up. */ + /* Store a copy of %^H that pp_entereval can pick up. */ HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv)); - OP *hhop; + OP *hhop; STOREFEATUREBITSHH(hh); hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh)); /* append hhop to only child */ op_sibling_splice(o, cUNOPo->op_first, 0, hhop); - o->op_private |= OPpEVAL_HAS_HH; + o->op_private |= OPpEVAL_HAS_HH; } if (!(o->op_private & OPpEVAL_BYTES) - && FEATURE_UNIEVAL_IS_ENABLED) - o->op_private |= OPpEVAL_UNICODE; + && FEATURE_UNIEVAL_IS_ENABLED) + o->op_private |= OPpEVAL_UNICODE; return o; } @@ -12924,13 +12924,13 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; - o = ck_fun(o); - kid = OpSIBLING(cUNOPo->op_first); - if (kid->op_type == OP_RV2GV) - op_null(kid); + o = ck_fun(o); + kid = OpSIBLING(cUNOPo->op_first); + if (kid->op_type == OP_RV2GV) + op_null(kid); } else - o = listkids(o); + o = listkids(o); return o; } @@ -12941,21 +12941,21 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { - OP * const kid = cUNOPo->op_first; - if (kid->op_type == OP_ENTERSUB) { - (void) ref(kid, o->op_type); - if (kid->op_type != OP_RV2CV - && !(PL_parser && PL_parser->error_count)) - Perl_croak(aTHX_ - "exists argument is not a subroutine name"); - o->op_private |= OPpEXISTS_SUB; - } - else if (kid->op_type == OP_AELEM) - o->op_flags |= OPf_SPECIAL; - else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " - "element or a subroutine"); - op_null(kid); + OP * const kid = cUNOPo->op_first; + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV + && !(PL_parser && PL_parser->error_count)) + Perl_croak(aTHX_ + "exists argument is not a subroutine name"); + o->op_private |= OPpEXISTS_SUB; + } + else if (kid->op_type == OP_AELEM) + o->op_flags |= OPf_SPECIAL; + else if (kid->op_type != OP_HELEM) + Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " + "element or a subroutine"); + op_null(kid); } return o; } @@ -12974,82 +12974,82 @@ Perl_ck_rvconst(pTHX_ OP *o) o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - int iscv; - GV *gv; - SV * const kidsv = kid->op_sv; - - /* Is it a constant from cv_const_sv()? */ - if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { - return o; - } - if (SvTYPE(kidsv) == SVt_PVAV) return o; - if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { - const char *badthing; - switch (o->op_type) { - case OP_RV2SV: - badthing = "a SCALAR"; - break; - case OP_RV2AV: - badthing = "an ARRAY"; - break; - case OP_RV2HV: - badthing = "a HASH"; - break; - default: - badthing = NULL; - break; - } - if (badthing) - Perl_croak(aTHX_ - "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", - SVfARG(kidsv), badthing); - } - /* - * This is a little tricky. We only want to add the symbol if we - * didn't add it in the lexer. Otherwise we get duplicate strict - * warnings. But if we didn't add it in the lexer, we must at - * least pretend like we wanted to add it even if it existed before, - * or we get possible typo warnings. OPpCONST_ENTERED says - * whether the lexer already added THIS instance of this symbol. - */ - iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; - gv = gv_fetchsv(kidsv, - o->op_type == OP_RV2CV - && o->op_private & OPpMAY_RETURN_CONSTANT - ? GV_NOEXPAND - : iscv | !(kid->op_private & OPpCONST_ENTERED), - iscv - ? SVt_PVCV - : o->op_type == OP_RV2SV - ? SVt_PV - : o->op_type == OP_RV2AV - ? SVt_PVAV - : o->op_type == OP_RV2HV - ? SVt_PVHV - : SVt_PVGV); - if (gv) { - if (!isGV(gv)) { - assert(iscv); - assert(SvROK(gv)); - if (!(o->op_private & OPpMAY_RETURN_CONSTANT) - && SvTYPE(SvRV(gv)) != SVt_PVCV) - gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); - } + int iscv; + GV *gv; + SV * const kidsv = kid->op_sv; + + /* Is it a constant from cv_const_sv()? */ + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { + return o; + } + if (SvTYPE(kidsv) == SVt_PVAV) return o; + if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + const char *badthing; + switch (o->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + default: + badthing = NULL; + break; + } + if (badthing) + Perl_croak(aTHX_ + "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", + SVfARG(kidsv), badthing); + } + /* + * This is a little tricky. We only want to add the symbol if we + * didn't add it in the lexer. Otherwise we get duplicate strict + * warnings. But if we didn't add it in the lexer, we must at + * least pretend like we wanted to add it even if it existed before, + * or we get possible typo warnings. OPpCONST_ENTERED says + * whether the lexer already added THIS instance of this symbol. + */ + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv + ? SVt_PVCV + : o->op_type == OP_RV2SV + ? SVt_PV + : o->op_type == OP_RV2AV + ? SVt_PVAV + : o->op_type == OP_RV2HV + ? SVt_PVHV + : SVt_PVGV); + if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } OpTYPE_set(kid, OP_GV); - SvREFCNT_dec(kid->op_sv); + SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS - /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ - STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); - SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); + /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ + STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); + PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else - kid->op_sv = SvREFCNT_inc_simple_NN(gv); + kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif - kid->op_private = 0; - /* FAKE globs in the symbol table cause weird bugs (#77810) */ - SvFAKE_off(gv); - } + kid->op_private = 0; + /* FAKE globs in the symbol table cause weird bugs (#77810) */ + SvFAKE_off(gv); + } } return o; } @@ -13062,19 +13062,19 @@ Perl_ck_ftst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_FTST; if (o->op_flags & OPf_REF) { - NOOP; + NOOP; } else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { - SVOP * const kid = (SVOP*)cUNOPo->op_first; - const OPCODE kidtype = kid->op_type; - - if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) - && !kid->op_folded) { - OP * const newop = newGVOP(type, OPf_REF, - gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); - op_free(o); - return newop; - } + SVOP * const kid = (SVOP*)cUNOPo->op_first; + const OPCODE kidtype = kid->op_type; + + if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) + && !kid->op_folded) { + OP * const newop = newGVOP(type, OPf_REF, + gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); + op_free(o); + return newop; + } if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) { SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2); @@ -13088,27 +13088,27 @@ Perl_ck_ftst(pTHX_ OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat); } } - scalar((OP *) kid); - if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) - o->op_private |= OPpFT_ACCESS; - if (OP_IS_FILETEST(type) + scalar((OP *) kid); + if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) + o->op_private |= OPpFT_ACCESS; + if (OP_IS_FILETEST(type) && OP_IS_FILETEST(kidtype) ) { - o->op_private |= OPpFT_STACKED; - kid->op_private |= OPpFT_STACKING; - if (kidtype == OP_FTTTY && ( - !(kid->op_private & OPpFT_STACKED) - || kid->op_private & OPpFT_AFTER_t - )) - o->op_private |= OPpFT_AFTER_t; - } + o->op_private |= OPpFT_STACKED; + kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; + } } else { - op_free(o); - if (type == OP_FTTTY) - o = newGVOP(type, OPf_REF, PL_stdingv); - else - o = newUNOP(type, 0, newDEFSVOP()); + op_free(o); + if (type == OP_FTTTY) + o = newGVOP(type, OPf_REF, PL_stdingv); + else + o = newUNOP(type, 0, newDEFSVOP()); } return o; } @@ -13122,110 +13122,110 @@ Perl_ck_fun(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_FUN; if (o->op_flags & OPf_STACKED) { - if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) - oa &= ~OA_OPTIONAL; - else - return no_fh_allowed(o); + if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) + oa &= ~OA_OPTIONAL; + else + return no_fh_allowed(o); } if (o->op_flags & OPf_KIDS) { OP *prev_kid = NULL; OP *kid = cLISTOPo->op_first; I32 numargs = 0; - bool seen_optional = FALSE; - - if (kid->op_type == OP_PUSHMARK || - (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) - { - prev_kid = kid; - kid = OpSIBLING(kid); - } - if (kid && kid->op_type == OP_COREARGS) { - bool optional = FALSE; - while (oa) { - numargs++; - if (oa & OA_OPTIONAL) optional = TRUE; - oa = oa >> 4; - } - if (optional) o->op_private |= numargs; - return o; - } - - while (oa) { - if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { - if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { - kid = newDEFSVOP(); + bool seen_optional = FALSE; + + if (kid->op_type == OP_PUSHMARK || + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) + { + prev_kid = kid; + kid = OpSIBLING(kid); + } + if (kid && kid->op_type == OP_COREARGS) { + bool optional = FALSE; + while (oa) { + numargs++; + if (oa & OA_OPTIONAL) optional = TRUE; + oa = oa >> 4; + } + if (optional) o->op_private |= numargs; + return o; + } + + while (oa) { + if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { + if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { + kid = newDEFSVOP(); /* append kid to chain */ op_sibling_splice(o, prev_kid, 0, kid); } - seen_optional = TRUE; - } - if (!kid) break; - - numargs++; - switch (oa & 7) { - case OA_SCALAR: - /* list seen where single (scalar) arg expected? */ - if (numargs == 1 && !(oa >> 4) - && kid->op_type == OP_LIST && type != OP_SCALAR) - { - return too_many_arguments_pv(o,PL_op_desc[type], 0); - } - if (type != OP_DELETE) scalar(kid); - break; - case OA_LIST: - if (oa < 16) { - kid = 0; - continue; - } - else - list(kid); - break; - case OA_AVREF: - if ((type == OP_PUSH || type == OP_UNSHIFT) - && !OpHAS_SIBLING(kid)) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless use of %s with no values", - PL_op_desc[type]); - - if (kid->op_type == OP_CONST - && ( !SvROK(cSVOPx_sv(kid)) - || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) - ) - bad_type_pv(numargs, "array", o, kid); + seen_optional = TRUE; + } + if (!kid) break; + + numargs++; + switch (oa & 7) { + case OA_SCALAR: + /* list seen where single (scalar) arg expected? */ + if (numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST && type != OP_SCALAR) + { + return too_many_arguments_pv(o,PL_op_desc[type], 0); + } + if (type != OP_DELETE) scalar(kid); + break; + case OA_LIST: + if (oa < 16) { + kid = 0; + continue; + } + else + list(kid); + break; + case OA_AVREF: + if ((type == OP_PUSH || type == OP_UNSHIFT) + && !OpHAS_SIBLING(kid)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless use of %s with no values", + PL_op_desc[type]); + + if (kid->op_type == OP_CONST + && ( !SvROK(cSVOPx_sv(kid)) + || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) + ) + bad_type_pv(numargs, "array", o, kid); else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV || kid->op_type == OP_RV2GV) { bad_type_pv(1, "array", o, kid); } - else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { + else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden", PL_op_desc[type]), 0); - } + } else { op_lvalue(kid, type); } - break; - case OA_HVREF: - if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type_pv(numargs, "hash", o, kid); - op_lvalue(kid, type); - break; - case OA_CVREF: - { + break; + case OA_HVREF: + if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) + bad_type_pv(numargs, "hash", o, kid); + op_lvalue(kid, type); + break; + case OA_CVREF: + { /* replace kid with newop in chain */ - OP * const newop = + OP * const newop = S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); - newop->op_next = newop; - kid = newop; - } - break; - case OA_FILEREF: - if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); + newop->op_next = newop; + kid = newop; + } + break; + case OA_FILEREF: + if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { + if (kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { + OP * const newop = newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); /* a first argument is handled by toke.c, ideally we'd just check here but several ops don't use ck_fun() */ if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) { @@ -13233,146 +13233,146 @@ Perl_ck_fun(pTHX_ OP *o) } /* replace kid with newop in chain */ op_sibling_splice(o, prev_kid, 1, newop); - op_free(kid); - kid = newop; - } - else if (kid->op_type == OP_READLINE) { - /* neophyte patrol: open(), close() etc. */ - bad_type_pv(numargs, "HANDLE", o, kid); - } - else { - I32 flags = OPf_SPECIAL; - I32 priv = 0; - PADOFFSET targ = 0; - - /* is this op a FH constructor? */ - if (is_handle_constructor(o,numargs)) { + op_free(kid); + kid = newop; + } + else if (kid->op_type == OP_READLINE) { + /* neophyte patrol: open(), close() etc. */ + bad_type_pv(numargs, "HANDLE", o, kid); + } + else { + I32 flags = OPf_SPECIAL; + I32 priv = 0; + PADOFFSET targ = 0; + + /* is this op a FH constructor? */ + if (is_handle_constructor(o,numargs)) { const char *name = NULL; - STRLEN len = 0; + STRLEN len = 0; U32 name_utf8 = 0; - bool want_dollar = TRUE; - - flags = 0; - /* Set a flag to tell rv2gv to vivify - * need to "prove" flag does not mean something - * else already - NI-S 1999/05/07 - */ - priv = OPpDEREF; - if (kid->op_type == OP_PADSV) { - PADNAME * const pn - = PAD_COMPNAME_SV(kid->op_targ); - name = PadnamePV (pn); - len = PadnameLEN(pn); - name_utf8 = PadnameUTF8(pn); - } - else if (kid->op_type == OP_RV2SV - && kUNOP->op_first->op_type == OP_GV) - { - GV * const gv = cGVOPx_gv(kUNOP->op_first); - name = GvNAME(gv); - len = GvNAMELEN(gv); + bool want_dollar = TRUE; + + flags = 0; + /* Set a flag to tell rv2gv to vivify + * need to "prove" flag does not mean something + * else already - NI-S 1999/05/07 + */ + priv = OPpDEREF; + if (kid->op_type == OP_PADSV) { + PADNAME * const pn + = PAD_COMPNAME_SV(kid->op_targ); + name = PadnamePV (pn); + len = PadnameLEN(pn); + name_utf8 = PadnameUTF8(pn); + } + else if (kid->op_type == OP_RV2SV + && kUNOP->op_first->op_type == OP_GV) + { + GV * const gv = cGVOPx_gv(kUNOP->op_first); + name = GvNAME(gv); + len = GvNAMELEN(gv); name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0; - } - else if (kid->op_type == OP_AELEM - || kid->op_type == OP_HELEM) - { - OP *firstop; - OP *op = ((BINOP*)kid)->op_first; - name = NULL; - if (op) { - SV *tmpstr = NULL; - const char * const a = - kid->op_type == OP_AELEM ? - "[]" : "{}"; - if (((op->op_type == OP_RV2AV) || - (op->op_type == OP_RV2HV)) && - (firstop = ((UNOP*)op)->op_first) && - (firstop->op_type == OP_GV)) { - /* packagevar $a[] or $h{} */ - GV * const gv = cGVOPx_gv(firstop); - if (gv) - tmpstr = - Perl_newSVpvf(aTHX_ - "%s%c...%c", - GvNAME(gv), - a[0], a[1]); - } - else if (op->op_type == OP_PADAV - || op->op_type == OP_PADHV) { - /* lexicalvar $a[] or $h{} */ - const char * const padname = - PAD_COMPNAME_PV(op->op_targ); - if (padname) - tmpstr = - Perl_newSVpvf(aTHX_ - "%s%c...%c", - padname + 1, - a[0], a[1]); - } - if (tmpstr) { - name = SvPV_const(tmpstr, len); + } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + OP *firstop; + OP *op = ((BINOP*)kid)->op_first; + name = NULL; + if (op) { + SV *tmpstr = NULL; + const char * const a = + kid->op_type == OP_AELEM ? + "[]" : "{}"; + if (((op->op_type == OP_RV2AV) || + (op->op_type == OP_RV2HV)) && + (firstop = ((UNOP*)op)->op_first) && + (firstop->op_type == OP_GV)) { + /* packagevar $a[] or $h{} */ + GV * const gv = cGVOPx_gv(firstop); + if (gv) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + GvNAME(gv), + a[0], a[1]); + } + else if (op->op_type == OP_PADAV + || op->op_type == OP_PADHV) { + /* lexicalvar $a[] or $h{} */ + const char * const padname = + PAD_COMPNAME_PV(op->op_targ); + if (padname) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + padname + 1, + a[0], a[1]); + } + if (tmpstr) { + name = SvPV_const(tmpstr, len); name_utf8 = SvUTF8(tmpstr); - sv_2mortal(tmpstr); - } - } - if (!name) { - name = "__ANONIO__"; - len = 10; - want_dollar = FALSE; - } - op_lvalue(kid, type); - } - if (name) { - SV *namesv; - targ = pad_alloc(OP_RV2GV, SVf_READONLY); - namesv = PAD_SVl(targ); - if (want_dollar && *name != '$') - sv_setpvs(namesv, "$"); - else + sv_2mortal(tmpstr); + } + } + if (!name) { + name = "__ANONIO__"; + len = 10; + want_dollar = FALSE; + } + op_lvalue(kid, type); + } + if (name) { + SV *namesv; + targ = pad_alloc(OP_RV2GV, SVf_READONLY); + namesv = PAD_SVl(targ); + if (want_dollar && *name != '$') + sv_setpvs(namesv, "$"); + else SvPVCLEAR(namesv); - sv_catpvn(namesv, name, len); + sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); - } - } + } + } scalar(kid); kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_RV2GV, flags); kid->op_targ = targ; kid->op_private |= priv; - } - } - scalar(kid); - break; - case OA_SCALARREF: - if ((type == OP_UNDEF || type == OP_POS) - && numargs == 1 && !(oa >> 4) - && kid->op_type == OP_LIST) - return too_many_arguments_pv(o,PL_op_desc[type], 0); - op_lvalue(scalar(kid), type); - break; - } - oa >>= 4; - prev_kid = kid; - kid = OpSIBLING(kid); - } - /* FIXME - should the numargs or-ing move after the too many + } + } + scalar(kid); + break; + case OA_SCALARREF: + if ((type == OP_UNDEF || type == OP_POS) + && numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST) + return too_many_arguments_pv(o,PL_op_desc[type], 0); + op_lvalue(scalar(kid), type); + break; + } + oa >>= 4; + prev_kid = kid; + kid = OpSIBLING(kid); + } + /* FIXME - should the numargs or-ing move after the too many * arguments check? */ - o->op_private |= numargs; - if (kid) - return too_many_arguments_pv(o,OP_DESC(o), 0); - listkids(o); + o->op_private |= numargs; + if (kid) + return too_many_arguments_pv(o,OP_DESC(o), 0); + listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { - /* Ordering of these two is important to keep f_map.t passing. */ - op_free(o); - return newUNOP(type, 0, newDEFSVOP()); + /* Ordering of these two is important to keep f_map.t passing. */ + op_free(o); + return newUNOP(type, 0, newDEFSVOP()); } if (oa) { - while (oa & OA_OPTIONAL) - oa >>= 4; - if (oa && oa != OA_LIST) - return too_few_arguments_pv(o,OP_DESC(o), 0); + while (oa & OA_OPTIONAL) + oa >>= 4; + if (oa && oa != OA_LIST) + return too_few_arguments_pv(o,OP_DESC(o), 0); } return o; } @@ -13386,36 +13386,36 @@ Perl_ck_glob(pTHX_ OP *o) o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first)) - op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ + op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) { - /* convert - * glob - * \ null - const(wildcard) - * into - * null - * \ enter - * \ list - * \ mark - glob - rv2cv - * | \ gv(CORE::GLOBAL::glob) - * | - * \ null - const(wildcard) - */ - o->op_flags |= OPf_SPECIAL; - o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - o = S_new_entersubop(aTHX_ gv, o); - o = newUNOP(OP_NULL, 0, o); - o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ - return o; + /* convert + * glob + * \ null - const(wildcard) + * into + * null + * \ enter + * \ list + * \ mark - glob - rv2cv + * | \ gv(CORE::GLOBAL::glob) + * | + * \ null - const(wildcard) + */ + o->op_flags |= OPf_SPECIAL; + o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); + o = S_new_entersubop(aTHX_ gv, o); + o = newUNOP(OP_NULL, 0, o); + o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ + return o; } else o->op_flags &= ~OPf_SPECIAL; #if !defined(PERL_EXTERNAL_GLOB) if (!PL_globhook) { - ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs("File::Glob"), NULL, NULL, NULL); - LEAVE; + ENTER; + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs("File::Glob"), NULL, NULL, NULL); + LEAVE; } #endif /* !PERL_EXTERNAL_GLOB */ gv = (GV *)newSV(0); @@ -13439,22 +13439,22 @@ Perl_ck_grep(pTHX_ OP *o) /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { - kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; - if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) - return no_fh_allowed(o); - o->op_flags &= ~OPf_STACKED; + kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; + if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) + return no_fh_allowed(o); + o->op_flags &= ~OPf_STACKED; } kid = OpSIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) - list(kid); + list(kid); else - scalar(kid); + scalar(kid); o = ck_fun(o); if (PL_parser && PL_parser->error_count) - return o; + return o; kid = OpSIBLING(cLISTOPo->op_first); if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); + Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; gwop = alloc_LOGOP(type, o, LINKLIST(kid)); @@ -13464,7 +13464,7 @@ Perl_ck_grep(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) - op_lvalue(kid, OP_GREPSTART); + op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; } @@ -13475,26 +13475,26 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ - if (kid) - kid = OpSIBLING(kid); /* get past "big" */ - if (kid && kid->op_type == OP_CONST) { - const bool save_taint = TAINT_get; - SV *sv = kSVOP->op_sv; - if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid) + kid = OpSIBLING(kid); /* get past "big" */ + if (kid && kid->op_type == OP_CONST) { + const bool save_taint = TAINT_get; + SV *sv = kSVOP->op_sv; + if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) && SvOK(sv) && !SvROK(sv)) { - sv = newSV(0); - sv_copypv(sv, kSVOP->op_sv); - SvREFCNT_dec_NN(kSVOP->op_sv); - kSVOP->op_sv = sv; - } - if (SvOK(sv)) fbm_compile(sv, 0); - TAINT_set(save_taint); + sv = newSV(0); + sv_copypv(sv, kSVOP->op_sv); + SvREFCNT_dec_NN(kSVOP->op_sv); + kSVOP->op_sv = sv; + } + if (SvOK(sv)) fbm_compile(sv, 0); + TAINT_set(save_taint); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(save_taint); #endif - } + } } return ck_fun(o); } @@ -13515,23 +13515,23 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ PERL_ARGS_ASSERT_CK_DEFINED; if ((o->op_flags & OPf_KIDS)) { - switch (cUNOPo->op_first->op_type) { - case OP_RV2AV: - case OP_PADAV: - Perl_croak(aTHX_ "Can't use 'defined(@array)'" - " (Maybe you should just omit the defined()?)"); + switch (cUNOPo->op_first->op_type) { + case OP_RV2AV: + case OP_PADAV: + Perl_croak(aTHX_ "Can't use 'defined(@array)'" + " (Maybe you should just omit the defined()?)"); NOT_REACHED; /* NOTREACHED */ break; - case OP_RV2HV: - case OP_PADHV: - Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" - " (Maybe you should just omit the defined()?)"); + case OP_RV2HV: + case OP_PADHV: + Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" + " (Maybe you should just omit the defined()?)"); NOT_REACHED; /* NOTREACHED */ - break; - default: - /* no warning */ - break; - } + break; + default: + /* no warning */ + break; + } } return ck_rfun(o); } @@ -13542,15 +13542,15 @@ Perl_ck_readline(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_READLINE; if (o->op_flags & OPf_KIDS) { - OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; scalar(kid); } else { - OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); - op_free(o); - return newop; + OP * const newop + = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + return newop; } return o; } @@ -13574,27 +13574,27 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; if (!kid) { - o = force_list(o, 1); - kid = cLISTOPo->op_first; + o = force_list(o, 1); + kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = OpSIBLING(kid); + kid = OpSIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = OpSIBLING(kid); + kid = OpSIBLING(kid); else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */ - if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE - && !kid->op_folded) { - o->op_flags |= OPf_STACKED; /* make it a filehandle */ + if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE + && !kid->op_folded) { + o->op_flags |= OPf_STACKED; /* make it a filehandle */ scalar(kid); /* replace old const op with new OP_RV2GV parent */ kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, OP_RV2GV, OPf_REF); kid = OpSIBLING(kid); - } + } } if (!kid) - op_append_elem(o->op_type, o, newDEFSVOP()); + op_append_elem(o->op_type, o, newDEFSVOP()); if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); return listkids(o); @@ -13605,26 +13605,26 @@ Perl_ck_smartmatch(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_SMARTMATCH; if (0 == (o->op_flags & OPf_SPECIAL)) { - OP *first = cBINOPo->op_first; - OP *second = OpSIBLING(first); + OP *first = cBINOPo->op_first; + OP *second = OpSIBLING(first); - /* Implicitly take a reference to an array or hash */ + /* Implicitly take a reference to an array or hash */ /* remove the original two siblings, then add back the * (possibly different) first and second sibs. */ op_sibling_splice(o, NULL, 1, NULL); op_sibling_splice(o, NULL, 1, NULL); - first = ref_array_or_hash(first); - second = ref_array_or_hash(second); + first = ref_array_or_hash(first); + second = ref_array_or_hash(second); op_sibling_splice(o, NULL, 0, second); op_sibling_splice(o, NULL, 0, first); - /* Implicitly take a reference to a regular expression */ - if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { + /* Implicitly take a reference to a regular expression */ + if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { OpTYPE_set(first, OP_QR); - } - if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { + } + if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { OpTYPE_set(second, OP_QR); } } @@ -13639,27 +13639,27 @@ S_maybe_targlex(pTHX_ OP *o) OP * const kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) - && !(kid->op_flags & OPf_STACKED) - /* Cannot steal the second time! */ - && !(kid->op_private & OPpTARGET_MY) - ) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY) + ) { - OP * const kkid = OpSIBLING(kid); - - /* Can just relocate the target. */ - if (kkid && kkid->op_type == OP_PADSV - && (!(kkid->op_private & OPpLVAL_INTRO) - || kkid->op_private & OPpPAD_STATE)) - { - kid->op_targ = kkid->op_targ; - kkid->op_targ = 0; - /* Now we do not need PADSV and SASSIGN. - * Detach kid and free the rest. */ - op_sibling_splice(o, NULL, 1, NULL); - op_free(o); - kid->op_private |= OPpTARGET_MY; /* Used for context settings */ - return kid; - } + OP * const kkid = OpSIBLING(kid); + + /* Can just relocate the target. */ + if (kkid && kkid->op_type == OP_PADSV + && (!(kkid->op_private & OPpLVAL_INTRO) + || kkid->op_private & OPpPAD_STATE)) + { + kid->op_targ = kkid->op_targ; + kkid->op_targ = 0; + /* Now we do not need PADSV and SASSIGN. + * Detach kid and free the rest. */ + op_sibling_splice(o, NULL, 1, NULL); + op_free(o); + kid->op_private |= OPpTARGET_MY; /* Used for context settings */ + return kid; + } } return o; } @@ -13672,18 +13672,18 @@ Perl_ck_sassign(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SASSIGN; if (OpHAS_SIBLING(kid)) { - OP *kkid = OpSIBLING(kid); - /* For state variable assignment with attributes, kkid is a list op - whose op_last is a padsv. */ - if ((kkid->op_type == OP_PADSV || - (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && - (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV - ) - ) - && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) - == (OPpLVAL_INTRO|OPpPAD_STATE)) { - return S_newONCEOP(aTHX_ o, kkid); - } + OP *kkid = OpSIBLING(kid); + /* For state variable assignment with attributes, kkid is a list op + whose op_last is a padsv. */ + if ((kkid->op_type == OP_PADSV || + (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && + (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV + ) + ) + && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == (OPpLVAL_INTRO|OPpPAD_STATE)) { + return S_newONCEOP(aTHX_ o, kkid); + } } return S_maybe_targlex(aTHX_ o); } @@ -13775,24 +13775,24 @@ Perl_ck_open(pTHX_ OP *o) S_io_hints(aTHX_ o); { - /* In case of three-arg dup open remove strictness - * from the last arg if it is a bareword. */ - OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ - OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ - OP *oa; - const char *mode; - - if ((last->op_type == OP_CONST) && /* The bareword. */ - (last->op_private & OPpCONST_BARE) && - (last->op_private & OPpCONST_STRICT) && - (oa = OpSIBLING(first)) && /* The fh. */ - (oa = OpSIBLING(oa)) && /* The mode. */ - (oa->op_type == OP_CONST) && - SvPOK(((SVOP*)oa)->op_sv) && - (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && - mode[0] == '>' && mode[1] == '&' && /* A dup open. */ - (last == OpSIBLING(oa))) /* The bareword. */ - last->op_private &= ~OPpCONST_STRICT; + /* In case of three-arg dup open remove strictness + * from the last arg if it is a bareword. */ + OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ + OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ + OP *oa; + const char *mode; + + if ((last->op_type == OP_CONST) && /* The bareword. */ + (last->op_private & OPpCONST_BARE) && + (last->op_private & OPpCONST_STRICT) && + (oa = OpSIBLING(first)) && /* The fh. */ + (oa = OpSIBLING(oa)) && /* The mode. */ + (oa->op_type == OP_CONST) && + SvPOK(((SVOP*)oa)->op_sv) && + (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && + mode[0] == '>' && mode[1] == '&' && /* A dup open. */ + (last == OpSIBLING(oa))) /* The bareword. */ + last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); } @@ -13802,8 +13802,8 @@ Perl_ck_prototype(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_PROTOTYPE; if (!(o->op_flags & OPf_KIDS)) { - op_free(o); - return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); + op_free(o); + return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); } return o; } @@ -13828,43 +13828,43 @@ Perl_ck_refassign(pTHX_ OP *o) switch (varop->op_type) { case OP_PADAV: - o->op_private |= OPpLVREF_AV; - goto settarg; + o->op_private |= OPpLVREF_AV; + goto settarg; case OP_PADHV: - o->op_private |= OPpLVREF_HV; + o->op_private |= OPpLVREF_HV; /* FALLTHROUGH */ case OP_PADSV: settarg: o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); - o->op_targ = varop->op_targ; - varop->op_targ = 0; - PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); - break; + o->op_targ = varop->op_targ; + varop->op_targ = 0; + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; case OP_RV2AV: - o->op_private |= OPpLVREF_AV; - goto checkgv; + o->op_private |= OPpLVREF_AV; + goto checkgv; NOT_REACHED; /* NOTREACHED */ case OP_RV2HV: - o->op_private |= OPpLVREF_HV; + o->op_private |= OPpLVREF_HV; /* FALLTHROUGH */ case OP_RV2SV: checkgv: o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)); - if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; + if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; detach_and_stack: - /* Point varop to its GV kid, detached. */ - varop = op_sibling_splice(varop, NULL, -1, NULL); - stacked = TRUE; - break; + /* Point varop to its GV kid, detached. */ + varop = op_sibling_splice(varop, NULL, -1, NULL); + stacked = TRUE; + break; case OP_RV2CV: { - OP * const kidparent = - OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); - OP * const kid = cUNOPx(kidparent)->op_first; - o->op_private |= OPpLVREF_CV; - if (kid->op_type == OP_GV) { + OP * const kidparent = + OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); + OP * const kid = cUNOPx(kidparent)->op_first; + o->op_private |= OPpLVREF_CV; + if (kid->op_type == OP_GV) { SV *sv = (SV*)cGVOPx_gv(kid); - varop = kidparent; + varop = kidparent; if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { /* a CVREF here confuses pp_refassign, so make sure it gets a GV */ @@ -13873,43 +13873,43 @@ Perl_ck_refassign(pTHX_ OP *o) (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0); assert(SvTYPE(sv) == SVt_PVGV); } - goto detach_and_stack; - } - if (kid->op_type != OP_PADCV) goto bad; - o->op_targ = kid->op_targ; - kid->op_targ = 0; - break; + goto detach_and_stack; + } + if (kid->op_type != OP_PADCV) goto bad; + o->op_targ = kid->op_targ; + kid->op_targ = 0; + break; } case OP_AELEM: case OP_HELEM: o->op_private |= (varop->op_private & OPpLVAL_INTRO); - o->op_private |= OPpLVREF_ELEM; - op_null(varop); - stacked = TRUE; - /* Detach varop. */ - op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); - break; + o->op_private |= OPpLVREF_ELEM; + op_null(varop); + stacked = TRUE; + /* Detach varop. */ + op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); + break; default: bad: - /* diag_listed_as: Can't modify reference to %s in %s assignment */ - yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " - "assignment", - OP_DESC(varop))); - return o; + /* diag_listed_as: Can't modify reference to %s in %s assignment */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " + "assignment", + OP_DESC(varop))); + return o; } if (!FEATURE_REFALIASING_IS_ENABLED) - Perl_croak(aTHX_ - "Experimental aliasing via reference not enabled"); + Perl_croak(aTHX_ + "Experimental aliasing via reference not enabled"); Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__REFALIASING), - "Aliasing via reference is experimental"); + packWARN(WARN_EXPERIMENTAL__REFALIASING), + "Aliasing via reference is experimental"); if (stacked) { - o->op_flags |= OPf_STACKED; - op_sibling_splice(o, right, 1, varop); + o->op_flags |= OPf_STACKED; + op_sibling_splice(o, right, 1, varop); } else { - o->op_flags &=~ OPf_STACKED; - op_sibling_splice(o, right, 1, NULL); + o->op_flags &=~ OPf_STACKED; + op_sibling_splice(o, right, 1, NULL); } op_free(left); return o; @@ -13922,13 +13922,13 @@ Perl_ck_repeat(pTHX_ OP *o) if (cBINOPo->op_first->op_flags & OPf_PARENS) { OP* kids; - o->op_private |= OPpREPEAT_DOLIST; + o->op_private |= OPpREPEAT_DOLIST; kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */ kids = force_list(kids, 1); /* promote it to a list */ op_sibling_splice(o, NULL, 0, kids); /* and add back */ } else - scalar(o); + scalar(o); return o; } @@ -13940,86 +13940,86 @@ Perl_ck_require(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP * const kid = (SVOP*)cUNOPo->op_first; - U32 hash; - char *s; - STRLEN len; - if (kid->op_type == OP_CONST) { - SV * const sv = kid->op_sv; - U32 const was_readonly = SvREADONLY(sv); - if (kid->op_private & OPpCONST_BARE) { - const char *end; + SVOP * const kid = (SVOP*)cUNOPo->op_first; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + const char *end; HEK *hek; - if (was_readonly) { + if (was_readonly) { SvREADONLY_off(sv); } - if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); - s = SvPVX(sv); - len = SvCUR(sv); - end = s + len; + s = SvPVX(sv); + len = SvCUR(sv); + end = s + len; /* treat ::foo::bar as foo::bar */ if (len >= 2 && s[0] == ':' && s[1] == ':') DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); if (s == end) DIE(aTHX_ "Bareword in require maps to empty filename"); - for (; s < end; s++) { - if (*s == ':' && s[1] == ':') { - *s = '/'; - Move(s+2, s+1, end - s - 1, char); - --end; - } - } - SvEND_set(sv, end); - sv_catpvs(sv, ".pm"); - PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); - hek = share_hek(SvPVX(sv), - (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), - hash); - sv_sethek(sv, hek); - unshare_hek(hek); - SvFLAGS(sv) |= was_readonly; - } - else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv) - && !SvVOK(sv)) { - s = SvPV(sv, len); - if (SvREFCNT(sv) > 1) { - kid->op_sv = newSVpvn_share( - s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); - SvREFCNT_dec_NN(sv); - } - else { + for (; s < end; s++) { + if (*s == ':' && s[1] == ':') { + *s = '/'; + Move(s+2, s+1, end - s - 1, char); + --end; + } + } + SvEND_set(sv, end); + sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv) + && !SvVOK(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { HEK *hek; - if (was_readonly) SvREADONLY_off(sv); - PERL_HASH(hash, s, len); - hek = share_hek(s, - SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, - hash); - sv_sethek(sv, hek); - unshare_hek(hek); - SvFLAGS(sv) |= was_readonly; - } - } - } + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } + } } if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ - /* handle override, if any */ + /* handle override, if any */ && (gv = gv_override("require", 7))) { - OP *kid, *newop; - if (o->op_flags & OPf_KIDS) { - kid = cUNOPo->op_first; + OP *kid, *newop; + if (o->op_flags & OPf_KIDS) { + kid = cUNOPo->op_first; op_sibling_splice(o, NULL, -1, NULL); - } - else { - kid = newDEFSVOP(); - } - op_free(o); - newop = S_new_entersubop(aTHX_ gv, kid); - return newop; + } + else { + kid = newDEFSVOP(); + } + op_free(o); + newop = S_new_entersubop(aTHX_ gv, kid); + return newop; } return ck_fun(o); @@ -14034,8 +14034,8 @@ Perl_ck_return(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); if (PL_compcv && CvLVALUE(PL_compcv)) { - for (; kid; kid = OpSIBLING(kid)) - op_lvalue(kid, OP_LEAVESUBLV); + for (; kid; kid = OpSIBLING(kid)) + op_lvalue(kid, OP_LEAVESUBLV); } return o; @@ -14052,14 +14052,14 @@ Perl_ck_select(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && OpHAS_SIBLING(kid)) { OpTYPE_set(o, OP_SSELECT); - o = ck_fun(o); - return fold_constants(op_integerize(op_std_init(o))); - } + o = ck_fun(o); + return fold_constants(op_integerize(op_std_init(o))); + } } o = ck_fun(o); kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) - kid->op_private &= ~HINT_STRICT_REFS; + kid->op_private &= ~HINT_STRICT_REFS; return o; } @@ -14071,16 +14071,16 @@ Perl_ck_shift(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { - OP *argop; + OP *argop; - if (!CvUNIQUE(PL_compcv)) { - o->op_flags |= OPf_SPECIAL; - return o; - } + if (!CvUNIQUE(PL_compcv)) { + o->op_flags |= OPf_SPECIAL; + return o; + } - argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); - op_free(o); - return newUNOP(type, 0, scalar(argop)); + argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); + op_free(o); + return newUNOP(type, 0, scalar(argop)); } return scalar(ck_fun(o)); } @@ -14091,80 +14091,80 @@ Perl_ck_sort(pTHX_ OP *o) OP *firstkid; OP *kid; HV * const hinthv = - PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; U8 stacked; PERL_ARGS_ASSERT_CK_SORT; if (hinthv) { - SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); - if (svp) { - const I32 sorthints = (I32)SvIV(*svp); - if ((sorthints & HINT_SORT_STABLE) != 0) - o->op_private |= OPpSORT_STABLE; - if ((sorthints & HINT_SORT_UNSTABLE) != 0) - o->op_private |= OPpSORT_UNSTABLE; - } + SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); + if (svp) { + const I32 sorthints = (I32)SvIV(*svp); + if ((sorthints & HINT_SORT_STABLE) != 0) + o->op_private |= OPpSORT_STABLE; + if ((sorthints & HINT_SORT_UNSTABLE) != 0) + o->op_private |= OPpSORT_UNSTABLE; + } } if (o->op_flags & OPf_STACKED) - simplify_sort(o); + simplify_sort(o); firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ - OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ /* if the first arg is a code block, process it and mark sort as * OPf_SPECIAL */ - if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { - LINKLIST(kid); - if (kid->op_type == OP_LEAVE) - op_null(kid); /* wipe out leave */ - /* Prevent execution from escaping out of the sort block. */ - kid->op_next = 0; - - /* provide scalar context for comparison function/block */ - kid = scalar(firstkid); - kid->op_next = kid; - o->op_flags |= OPf_SPECIAL; - } - else if (kid->op_type == OP_CONST - && kid->op_private & OPpCONST_BARE) { - char tmpbuf[256]; - STRLEN len; - PADOFFSET off; - const char * const name = SvPV(kSVOP_sv, len); - *tmpbuf = '&'; - assert (len < 256); - Copy(name, tmpbuf+1, len, char); - off = pad_findmy_pvn(tmpbuf, len+1, 0); - if (off != NOT_IN_PAD) { - if (PAD_COMPNAME_FLAGS_isOUR(off)) { - SV * const fq = - newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); - sv_catpvs(fq, "::"); - sv_catsv(fq, kSVOP_sv); - SvREFCNT_dec_NN(kSVOP_sv); - kSVOP->op_sv = fq; - } - else { - OP * const padop = newOP(OP_PADCV, 0); - padop->op_targ = off; + if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { + LINKLIST(kid); + if (kid->op_type == OP_LEAVE) + op_null(kid); /* wipe out leave */ + /* Prevent execution from escaping out of the sort block. */ + kid->op_next = 0; + + /* provide scalar context for comparison function/block */ + kid = scalar(firstkid); + kid->op_next = kid; + o->op_flags |= OPf_SPECIAL; + } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, 0); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; /* replace the const op with the pad op */ op_sibling_splice(firstkid, NULL, 1, padop); - op_free(kid); - } - } - } + op_free(kid); + } + } + } - firstkid = OpSIBLING(firstkid); + firstkid = OpSIBLING(firstkid); } for (kid = firstkid; kid; kid = OpSIBLING(kid)) { - /* provide list context for arguments */ - list(kid); - if (stacked) - op_lvalue(kid, OP_GREPSTART); + /* provide list context for arguments */ + list(kid); + if (stacked) + op_lvalue(kid, OP_GREPSTART); } return o; @@ -14174,9 +14174,9 @@ Perl_ck_sort(pTHX_ OP *o) * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a * elide the second child of the sort (the one containing X), * and set these flags as appropriate - OPpSORT_NUMERIC; - OPpSORT_INTEGER; - OPpSORT_DESCEND; + OPpSORT_NUMERIC; + OPpSORT_INTEGER; + OPpSORT_DESCEND; * Also, check and warn on lexical $a, $b. */ @@ -14195,87 +14195,87 @@ S_simplify_sort(pTHX_ OP *o) kid = kUNOP->op_first; /* get past null */ if (!(have_scopeop = kid->op_type == OP_SCOPE) && kid->op_type != OP_LEAVE) - return; + return; kid = kLISTOP->op_last; /* get past scope */ switch(kid->op_type) { - case OP_NCMP: - case OP_I_NCMP: - case OP_SCMP: - if (!have_scopeop) goto padkids; - break; - default: - return; + case OP_NCMP: + case OP_I_NCMP: + case OP_SCMP: + if (!have_scopeop) goto padkids; + break; + default: + return; } k = kid; /* remember this node*/ if (kBINOP->op_first->op_type != OP_RV2SV || kBINOP->op_last ->op_type != OP_RV2SV) { - /* - Warn about my($a) or my($b) in a sort block, *if* $a or $b is - then used in a comparison. This catches most, but not - all cases. For instance, it catches - sort { my($a); $a <=> $b } - but not - sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } - (although why you'd do that is anyone's guess). - */ + /* + Warn about my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ padkids: - if (!ckWARN(WARN_SYNTAX)) return; - kid = kBINOP->op_first; - do { - if (kid->op_type == OP_PADSV) { - PADNAME * const name = PAD_COMPNAME(kid->op_targ); - if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' - && ( PadnamePV(name)[1] == 'a' - || PadnamePV(name)[1] == 'b' )) - /* diag_listed_as: "my %s" used in sort comparison */ - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\"%s %s\" used in sort comparison", - PadnameIsSTATE(name) - ? "state" - : "my", - PadnamePV(name)); - } - } while ((kid = OpSIBLING(kid))); - return; + if (!ckWARN(WARN_SYNTAX)) return; + kid = kBINOP->op_first; + do { + if (kid->op_type == OP_PADSV) { + PADNAME * const name = PAD_COMPNAME(kid->op_targ); + if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' + && ( PadnamePV(name)[1] == 'a' + || PadnamePV(name)[1] == 'b' )) + /* diag_listed_as: "my %s" used in sort comparison */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\"%s %s\" used in sort comparison", + PadnameIsSTATE(name) + ? "state" + : "my", + PadnamePV(name)); + } + } while ((kid = OpSIBLING(kid))); + return; } kid = kBINOP->op_first; /* get past cmp */ if (kUNOP->op_first->op_type != OP_GV) - return; + return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) - return; + return; gvname = GvNAME(gv); if (*gvname == 'a' && gvname[1] == '\0') - descending = 0; + descending = 0; else if (*gvname == 'b' && gvname[1] == '\0') - descending = 1; + descending = 1; else - return; + return; kid = k; /* back to cmp */ /* already checked above that it is rv2sv */ kid = kBINOP->op_last; /* down to 2nd arg */ if (kUNOP->op_first->op_type != OP_GV) - return; + return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) - return; + return; gvname = GvNAME(gv); if ( descending - ? !(*gvname == 'a' && gvname[1] == '\0') - : !(*gvname == 'b' && gvname[1] == '\0')) - return; + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) + return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (descending) - o->op_private |= OPpSORT_DESCEND; + o->op_private |= OPpSORT_DESCEND; if (k->op_type == OP_NCMP) - o->op_private |= OPpSORT_NUMERIC; + o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) - o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; + o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; kid = OpSIBLING(cLISTOPo->op_first); /* cut out and delete old block (second sibling) */ op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); @@ -14293,13 +14293,13 @@ Perl_ck_split(pTHX_ OP *o) assert(o->op_type == OP_LIST); if (o->op_flags & OPf_STACKED) - return no_fh_allowed(o); + return no_fh_allowed(o); kid = cLISTOPo->op_first; /* delete leading NULL node, then add a CONST if no other nodes */ assert(kid->op_type == OP_NULL); op_sibling_splice(o, NULL, 1, - OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); + OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); op_free(kid); kid = cLISTOPo->op_first; @@ -14316,7 +14316,7 @@ Perl_ck_split(pTHX_ OP *o) if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /g modifier is meaningless in split"); + "Use of /g modifier is meaningless in split"); } /* eliminate the split op, and move the match op (plus any children) @@ -14344,21 +14344,21 @@ Perl_ck_split(pTHX_ OP *o) kid = sibs; /* kid is now the string arg of the split */ if (!kid) { - kid = newDEFSVOP(); - op_append_elem(OP_SPLIT, o, kid); + kid = newDEFSVOP(); + op_append_elem(OP_SPLIT, o, kid); } scalar(kid); kid = OpSIBLING(kid); if (!kid) { kid = newSVOP(OP_CONST, 0, newSViv(0)); - op_append_elem(OP_SPLIT, o, kid); - o->op_private |= OPpSPLIT_IMPLIM; + op_append_elem(OP_SPLIT, o, kid); + o->op_private |= OPpSPLIT_IMPLIM; } scalar(kid); if (OpHAS_SIBLING(kid)) - return too_many_arguments_pv(o,OP_DESC(o), 0); + return too_many_arguments_pv(o,OP_DESC(o), 0); return o; } @@ -14371,11 +14371,11 @@ Perl_ck_stringify(pTHX_ OP *o) if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) - && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ + && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ { - op_sibling_splice(o, cUNOPo->op_first, -1, NULL); - op_free(o); - return kid; + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + op_free(o); + return kid; } return ck_fun(o); } @@ -14388,32 +14388,32 @@ Perl_ck_join(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_JOIN; if (kid && kid->op_type == OP_MATCH) { - if (ckWARN(WARN_SYNTAX)) { + if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const SV *msg = re ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) : newSVpvs_flags( "STRING", SVs_TEMP ); - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%" SVf "/ should probably be written as \"%" SVf "\"", - SVfARG(msg), SVfARG(msg)); - } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "/%" SVf "/ should probably be written as \"%" SVf "\"", + SVfARG(msg), SVfARG(msg)); + } } if (kid && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */ - || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) - || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV - && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) + || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) + || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV + && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) { - const OP * const bairn = OpSIBLING(kid); /* the list */ - if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ - && OP_GIMME(bairn,0) == G_SCALAR) - { - OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, - op_sibling_splice(o, kid, 1, NULL)); - op_free(o); - return ret; - } + const OP * const bairn = OpSIBLING(kid); /* the list */ + if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ + && OP_GIMME(bairn,0) == G_SCALAR) + { + OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, + op_sibling_splice(o, kid, 1, NULL)); + op_free(o); + return ret; + } } return ck_fun(o); @@ -14470,14 +14470,14 @@ Perl_find_lexical_cv(pTHX_ PADOFFSET off) PADNAME *name = PAD_COMPNAME(off); CV *compcv = PL_compcv; while (PadnameOUTER(name)) { - assert(PARENT_PAD_INDEX(name)); - compcv = CvOUTSIDE(compcv); - name = PadlistNAMESARRAY(CvPADLIST(compcv)) - [off = PARENT_PAD_INDEX(name)]; + assert(PARENT_PAD_INDEX(name)); + compcv = CvOUTSIDE(compcv); + name = PadlistNAMESARRAY(CvPADLIST(compcv)) + [off = PARENT_PAD_INDEX(name)]; } assert(!PadnameIsOUR(name)); if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) { - return PadnamePROTOCV(name); + return PadnamePROTOCV(name); } return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; } @@ -14490,65 +14490,65 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; if (flags & ~RV2CVOPCV_FLAG_MASK) - Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); + Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) - return NULL; + return NULL; if (cvop->op_private & OPpENTERSUB_AMPER) - return NULL; + return NULL; if (!(cvop->op_flags & OPf_KIDS)) - return NULL; + return NULL; rvop = cUNOPx(cvop)->op_first; switch (rvop->op_type) { - case OP_GV: { - gv = cGVOPx_gv(rvop); - if (!isGV(gv)) { - if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { - cv = MUTABLE_CV(SvRV(gv)); - gv = NULL; - break; - } - if (flags & RV2CVOPCV_RETURN_STUB) - return (CV *)gv; - else return NULL; - } - cv = GvCVu(gv); - if (!cv) { - if (flags & RV2CVOPCV_MARK_EARLY) - rvop->op_private |= OPpEARLY_CV; - return NULL; - } - } break; - case OP_CONST: { - SV *rv = cSVOPx_sv(rvop); - if (!SvROK(rv)) - return NULL; - cv = (CV*)SvRV(rv); - gv = NULL; - } break; - case OP_PADCV: { - cv = find_lexical_cv(rvop->op_targ); - gv = NULL; - } break; - default: { - return NULL; - } NOT_REACHED; /* NOTREACHED */ + case OP_GV: { + gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } + cv = GvCVu(gv); + if (!cv) { + if (flags & RV2CVOPCV_MARK_EARLY) + rvop->op_private |= OPpEARLY_CV; + return NULL; + } + } break; + case OP_CONST: { + SV *rv = cSVOPx_sv(rvop); + if (!SvROK(rv)) + return NULL; + cv = (CV*)SvRV(rv); + gv = NULL; + } break; + case OP_PADCV: { + cv = find_lexical_cv(rvop->op_targ); + gv = NULL; + } break; + default: { + return NULL; + } NOT_REACHED; /* NOTREACHED */ } if (SvTYPE((SV*)cv) != SVt_PVCV) - return NULL; + return NULL; if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) - gv = CvGV(cv); - return (CV*)gv; + if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) + gv = CvGV(cv); + return (CV*)gv; } else if (flags & RV2CVOPCV_MAYBE_NAME_GV) { - if (CvLEXICAL(cv) || CvNAMED(cv)) - return NULL; - if (!CvANON(cv) || !gv) - gv = CvGV(cv); - return (CV*)gv; + if (CvLEXICAL(cv) || CvNAMED(cv)) + return NULL; + if (!CvANON(cv) || !gv) + gv = CvGV(cv); + return (CV*)gv; } else { - return cv; + return cv; } } @@ -14574,7 +14574,7 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { /* skip the extra attributes->import() call implicitly added in * something like foo(my $x : bar) @@ -14629,10 +14629,10 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *e = NULL; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) - Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " - "flags=%lx", (unsigned long) SvFLAGS(protosv)); + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); if (SvTYPE(protosv) == SVt_PVCV) - proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); + proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; @@ -14640,199 +14640,199 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) { parent = aop; - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; } prev = aop; aop = OpSIBLING(aop); for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; while (aop != cvop) { - OP* o3 = aop; - - if (proto >= proto_end) - { - SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); - return entersubop; - } - - switch (*proto) { - case ';': - optional = 1; - proto++; - continue; - case '_': - /* _ must be at the end */ - if (proto[1] && !memCHRs(";@%", proto[1])) - goto oops; + OP* o3 = aop; + + if (proto >= proto_end) + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } + + switch (*proto) { + case ';': + optional = 1; + proto++; + continue; + case '_': + /* _ must be at the end */ + if (proto[1] && !memCHRs(";@%", proto[1])) + goto oops; /* FALLTHROUGH */ - case '$': - proto++; - arg++; - scalar(aop); - break; - case '%': - case '@': - list(aop); - arg++; - break; - case '&': - proto++; - arg++; - if ( o3->op_type != OP_UNDEF + case '$': + proto++; + arg++; + scalar(aop); + break; + case '%': + case '@': + list(aop); + arg++; + break; + case '&': + proto++; + arg++; + if ( o3->op_type != OP_UNDEF && (o3->op_type != OP_SREFGEN || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_ANONCODE && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_RV2CV))) - bad_type_gv(arg, namegv, o3, - arg == 1 ? "block or sub {}" : "sub {}"); - break; - case '*': - /* '*' allows any scalar type, including bareword */ - proto++; - arg++; - if (o3->op_type == OP_RV2GV) - goto wrapref; /* autoconvert GLOB -> GLOBref */ - else if (o3->op_type == OP_CONST) - o3->op_private &= ~OPpCONST_STRICT; - scalar(aop); - break; - case '+': - proto++; - arg++; - if (o3->op_type == OP_RV2AV || - o3->op_type == OP_PADAV || - o3->op_type == OP_RV2HV || - o3->op_type == OP_PADHV - ) { - goto wrapref; - } - scalar(aop); - break; - case '[': case ']': - goto oops; - - case '\\': - proto++; - arg++; - again: - switch (*proto++) { - case '[': - if (contextclass++ == 0) { - e = (char *) memchr(proto, ']', proto_end - proto); - if (!e || e == proto) - goto oops; - } - else - goto oops; - goto again; - - case ']': - if (contextclass) { - const char *p = proto; - const char *const end = proto; - contextclass = 0; - while (*--p != '[') - /* \[$] accepts any scalar lvalue */ - if (*p == '$' - && Perl_op_lvalue_flags(aTHX_ - scalar(o3), - OP_READ, /* not entersub */ - OP_LVALUE_NO_CROAK - )) goto wrapref; - bad_type_gv(arg, namegv, o3, - Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); - } else - goto oops; - break; - case '*': - if (o3->op_type == OP_RV2GV) - goto wrapref; - if (!contextclass) - bad_type_gv(arg, namegv, o3, "symbol"); - break; - case '&': - if (o3->op_type == OP_ENTERSUB - && !(o3->op_flags & OPf_STACKED)) - goto wrapref; - if (!contextclass) - bad_type_gv(arg, namegv, o3, "subroutine"); - break; - case '$': - if (o3->op_type == OP_RV2SV || - o3->op_type == OP_PADSV || - o3->op_type == OP_HELEM || - o3->op_type == OP_AELEM) - goto wrapref; - if (!contextclass) { - /* \$ accepts any scalar lvalue */ - if (Perl_op_lvalue_flags(aTHX_ - scalar(o3), - OP_READ, /* not entersub */ - OP_LVALUE_NO_CROAK - )) goto wrapref; - bad_type_gv(arg, namegv, o3, "scalar"); - } - break; - case '@': - if (o3->op_type == OP_RV2AV || - o3->op_type == OP_PADAV) - { - o3->op_flags &=~ OPf_PARENS; - goto wrapref; - } - if (!contextclass) - bad_type_gv(arg, namegv, o3, "array"); - break; - case '%': - if (o3->op_type == OP_RV2HV || - o3->op_type == OP_PADHV) - { - o3->op_flags &=~ OPf_PARENS; - goto wrapref; - } - if (!contextclass) - bad_type_gv(arg, namegv, o3, "hash"); - break; - wrapref: + bad_type_gv(arg, namegv, o3, + arg == 1 ? "block or sub {}" : "sub {}"); + break; + case '*': + /* '*' allows any scalar type, including bareword */ + proto++; + arg++; + if (o3->op_type == OP_RV2GV) + goto wrapref; /* autoconvert GLOB -> GLOBref */ + else if (o3->op_type == OP_CONST) + o3->op_private &= ~OPpCONST_STRICT; + scalar(aop); + break; + case '+': + proto++; + arg++; + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV || + o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV + ) { + goto wrapref; + } + scalar(aop); + break; + case '[': case ']': + goto oops; + + case '\\': + proto++; + arg++; + again: + switch (*proto++) { + case '[': + if (contextclass++ == 0) { + e = (char *) memchr(proto, ']', proto_end - proto); + if (!e || e == proto) + goto oops; + } + else + goto oops; + goto again; + + case ']': + if (contextclass) { + const char *p = proto; + const char *const end = proto; + contextclass = 0; + while (*--p != '[') + /* \[$] accepts any scalar lvalue */ + if (*p == '$' + && Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, + Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); + } else + goto oops; + break; + case '*': + if (o3->op_type == OP_RV2GV) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "symbol"); + break; + case '&': + if (o3->op_type == OP_ENTERSUB + && !(o3->op_flags & OPf_STACKED)) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "subroutine"); + break; + case '$': + if (o3->op_type == OP_RV2SV || + o3->op_type == OP_PADSV || + o3->op_type == OP_HELEM || + o3->op_type == OP_AELEM) + goto wrapref; + if (!contextclass) { + /* \$ accepts any scalar lvalue */ + if (Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, "scalar"); + } + break; + case '@': + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "array"); + break; + case '%': + if (o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "hash"); + break; + wrapref: aop = S_op_sibling_newUNOP(aTHX_ parent, prev, OP_REFGEN, 0); - if (contextclass && e) { - proto = e + 1; - contextclass = 0; - } - break; - default: goto oops; - } - if (contextclass) - goto again; - break; - case ' ': - proto++; - continue; - default: - oops: { - Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, - SVfARG(cv_name((CV *)namegv, NULL, 0)), - SVfARG(protosv)); + if (contextclass && e) { + proto = e + 1; + contextclass = 0; + } + break; + default: goto oops; + } + if (contextclass) + goto again; + break; + case ' ': + proto++; + continue; + default: + oops: { + Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, + SVfARG(cv_name((CV *)namegv, NULL, 0)), + SVfARG(protosv)); } - } + } - op_lvalue(aop, OP_ENTERSUB); - prev = aop; - aop = OpSIBLING(aop); + op_lvalue(aop, OP_ENTERSUB); + prev = aop; + aop = OpSIBLING(aop); } if (aop == cvop && *proto == '_') { - /* generate an access to $_ */ + /* generate an access to $_ */ op_sibling_splice(parent, prev, 0, newDEFSVOP()); } if (!optional && proto_end > proto && - (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) { - SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); } return entersubop; } @@ -14866,13 +14866,13 @@ by the name defined by the C parameter. OP * Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, - GV *namegv, SV *protosv) + GV *namegv, SV *protosv) { PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST; if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) - return ck_entersub_args_proto(entersubop, namegv, protosv); + return ck_entersub_args_proto(entersubop, namegv, protosv); else - return ck_entersub_args_list(entersubop); + return ck_entersub_args_list(entersubop); } OP * @@ -14885,53 +14885,53 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; if (!opnum) { - OP *cvop; - if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; - aop = OpSIBLING(aop); - for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; - if (aop != cvop) { - SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); - } - - op_free(entersubop); - switch(cvflags >> 16) { - case 'F': return newSVOP(OP_CONST, 0, - newSVpv(CopFILE(PL_curcop),0)); - case 'L': return newSVOP( - OP_CONST, 0, + OP *cvop; + if (!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + aop = OpSIBLING(aop); + for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; + if (aop != cvop) { + SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } + + op_free(entersubop); + switch(cvflags >> 16) { + case 'F': return newSVOP(OP_CONST, 0, + newSVpv(CopFILE(PL_curcop),0)); + case 'L': return newSVOP( + OP_CONST, 0, Perl_newSVpvf(aTHX_ - "%" IVdf, (IV)CopLINE(PL_curcop) - ) - ); - case 'P': return newSVOP(OP_CONST, 0, - (PL_curstash - ? newSVhek(HvNAME_HEK(PL_curstash)) - : &PL_sv_undef - ) - ); - } - NOT_REACHED; /* NOTREACHED */ + "%" IVdf, (IV)CopLINE(PL_curcop) + ) + ); + case 'P': return newSVOP(OP_CONST, 0, + (PL_curstash + ? newSVhek(HvNAME_HEK(PL_curstash)) + : &PL_sv_undef + ) + ); + } + NOT_REACHED; /* NOTREACHED */ } else { - OP *prev, *cvop, *first, *parent; - U32 flags = 0; + OP *prev, *cvop, *first, *parent; + U32 flags = 0; parent = entersubop; if (!OpHAS_SIBLING(aop)) { parent = aop; - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; } - first = prev = aop; - aop = OpSIBLING(aop); + first = prev = aop; + aop = OpSIBLING(aop); /* find last sibling */ - for (cvop = aop; - OpHAS_SIBLING(cvop); - prev = cvop, cvop = OpSIBLING(cvop)) - ; + for (cvop = aop; + OpHAS_SIBLING(cvop); + prev = cvop, cvop = OpSIBLING(cvop)) + ; if (!(cvop->op_private & OPpENTERSUB_NOPAREN) /* Usually, OPf_SPECIAL on an op with no args means that it had * parens, but these have their own meaning for that flag: */ @@ -14940,50 +14940,50 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) flags |= OPf_SPECIAL; /* excise cvop from end of sibling chain */ op_sibling_splice(parent, prev, 1, NULL); - op_free(cvop); - if (aop == cvop) aop = NULL; + op_free(cvop); + if (aop == cvop) aop = NULL; /* detach remaining siblings from the first sibling, then * dispose of original optree */ if (aop) op_sibling_splice(parent, first, -1, NULL); - op_free(entersubop); + op_free(entersubop); - if (cvflags == (OP_ENTEREVAL | (1<<16))) - flags |= OPpEVAL_BYTES <<8; + if (cvflags == (OP_ENTEREVAL | (1<<16))) + flags |= OPpEVAL_BYTES <<8; - switch (PL_opargs[opnum] & OA_CLASS_MASK) { - case OA_UNOP: - case OA_BASEOP_OR_UNOP: - case OA_FILESTATOP: - if (!aop) + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_UNOP: + case OA_BASEOP_OR_UNOP: + case OA_FILESTATOP: + if (!aop) return newOP(opnum,flags); /* zero args */ if (aop == prev) return newUNOP(opnum,flags,aop); /* one arg */ /* too many args */ /* FALLTHROUGH */ - case OA_BASEOP: - if (aop) { - SV *namesv; + case OA_BASEOP: + if (aop) { + SV *namesv; OP *nextop; - namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); + namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); while (aop) { nextop = OpSIBLING(aop); op_free(aop); aop = nextop; } - } - return opnum == OP_RUNCV - ? newPVOP(OP_RUNCV,0,NULL) - : newOP(opnum,0); - default: - return op_convert_list(opnum,0,aop); - } + } + return opnum == OP_RUNCV + ? newPVOP(OP_RUNCV,0,NULL) + : newOP(opnum,0); + default: + return op_convert_list(opnum,0,aop); + } } NOT_REACHED; /* NOTREACHED */ return entersubop; @@ -15049,20 +15049,20 @@ it is only safe to call it with a genuine GV as its C argument. void Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags, - Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p) + Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p) { MAGIC *callmg; PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS; PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { - *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); - *ckobj_p = callmg->mg_obj; - *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV; + *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); + *ckobj_p = callmg->mg_obj; + *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV; } else { - *ckfun_p = Perl_ck_entersub_args_proto_or_list; - *ckobj_p = (SV*)cv; - *ckflags_p = gflags & MGf_REQUIRE_GV; + *ckfun_p = Perl_ck_entersub_args_proto_or_list; + *ckobj_p = (SV*)cv; + *ckflags_p = gflags & MGf_REQUIRE_GV; } } @@ -15073,7 +15073,7 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; PERL_UNUSED_CONTEXT; cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p, - &ckflags); + &ckflags); } /* @@ -15132,29 +15132,29 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, - SV *ckobj, U32 ckflags) + SV *ckobj, U32 ckflags) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { - if (SvMAGICAL((SV*)cv)) - mg_free_type((SV*)cv, PERL_MAGIC_checkcall); + if (SvMAGICAL((SV*)cv)) + mg_free_type((SV*)cv, PERL_MAGIC_checkcall); } else { - MAGIC *callmg; - sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); - callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); - assert(callmg); - if (callmg->mg_flags & MGf_REFCOUNTED) { - SvREFCNT_dec(callmg->mg_obj); - callmg->mg_flags &= ~MGf_REFCOUNTED; - } - callmg->mg_ptr = FPTR2DPTR(char *, ckfun); - callmg->mg_obj = ckobj; - if (ckobj != (SV*)cv) { - SvREFCNT_inc_simple_void_NN(ckobj); - callmg->mg_flags |= MGf_REFCOUNTED; - } - callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) - | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY; + MAGIC *callmg; + sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); + callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); + assert(callmg); + if (callmg->mg_flags & MGf_REFCOUNTED) { + SvREFCNT_dec(callmg->mg_obj); + callmg->mg_flags &= ~MGf_REFCOUNTED; + } + callmg->mg_ptr = FPTR2DPTR(char *, ckfun); + callmg->mg_obj = ckobj; + if (ckobj != (SV*)cv) { + SvREFCNT_inc_simple_void_NN(ckobj); + callmg->mg_flags |= MGf_REFCOUNTED; + } + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -15177,7 +15177,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = cUNOPx(o)->op_first; if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; aop = OpSIBLING(aop); for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); @@ -15186,77 +15186,77 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private &= ~1; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) - o->op_private |= OPpENTERSUB_DB; + o->op_private |= OPpENTERSUB_DB; switch (cvop->op_type) { - case OP_RV2CV: - o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); - op_null(cvop); - break; - case OP_METHOD: - case OP_METHOD_NAMED: - case OP_METHOD_SUPER: - case OP_METHOD_REDIR: - case OP_METHOD_REDIR_SUPER: - o->op_flags |= OPf_REF; - if (aop->op_type == OP_CONST) { - aop->op_private &= ~OPpCONST_STRICT; - const_class = &cSVOPx(aop)->op_sv; - } - else if (aop->op_type == OP_LIST) { - OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); - if (sib && sib->op_type == OP_CONST) { - sib->op_private &= ~OPpCONST_STRICT; - const_class = &cSVOPx(sib)->op_sv; - } - } - /* make class name a shared cow string to speedup method calls */ - /* constant string might be replaced with object, f.e. bigint */ - if (const_class && SvPOK(*const_class)) { - STRLEN len; - const char* str = SvPV(*const_class, len); - if (len) { - SV* const shared = newSVpvn_share( - str, SvUTF8(*const_class) + case OP_RV2CV: + o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + op_null(cvop); + break; + case OP_METHOD: + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: + case OP_METHOD_REDIR_SUPER: + o->op_flags |= OPf_REF; + if (aop->op_type == OP_CONST) { + aop->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(aop)->op_sv; + } + else if (aop->op_type == OP_LIST) { + OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); + if (sib && sib->op_type == OP_CONST) { + sib->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(sib)->op_sv; + } + } + /* make class name a shared cow string to speedup method calls */ + /* constant string might be replaced with object, f.e. bigint */ + if (const_class && SvPOK(*const_class)) { + STRLEN len; + const char* str = SvPV(*const_class, len); + if (len) { + SV* const shared = newSVpvn_share( + str, SvUTF8(*const_class) ? -(SSize_t)len : (SSize_t)len, 0 - ); + ); if (SvREADONLY(*const_class)) SvREADONLY_on(shared); - SvREFCNT_dec(*const_class); - *const_class = shared; - } - } - break; + SvREFCNT_dec(*const_class); + *const_class = shared; + } + } + break; } if (!cv) { - S_entersub_alloc_targ(aTHX_ o); - return ck_entersub_args_list(o); + S_entersub_alloc_targ(aTHX_ o); + return ck_entersub_args_list(o); } else { - Perl_call_checker ckfun; - SV *ckobj; - U32 ckflags; - cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags); - if (CvISXSUB(cv) || !CvROOT(cv)) - S_entersub_alloc_targ(aTHX_ o); - if (!namegv) { - /* The original call checker API guarantees that a GV will - be provided with the right name. So, if the old API was - used (or the REQUIRE_GV flag was passed), we have to reify - the CV’s GV, unless this is an anonymous sub. This is not - ideal for lexical subs, as its stringification will include - the package. But it is the best we can do. */ - if (ckflags & CALL_CHECKER_REQUIRE_GV) { - if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) - namegv = CvGV(cv); - } - else namegv = MUTABLE_GV(cv); - /* After a syntax error in a lexical sub, the cv that - rv2cv_op_cv returns may be a nameless stub. */ - if (!namegv) return ck_entersub_args_list(o); - - } - return ckfun(aTHX_ o, namegv, ckobj); + Perl_call_checker ckfun; + SV *ckobj; + U32 ckflags; + cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags); + if (CvISXSUB(cv) || !CvROOT(cv)) + S_entersub_alloc_targ(aTHX_ o); + if (!namegv) { + /* The original call checker API guarantees that a GV will + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (ckflags & CALL_CHECKER_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); + /* After a syntax error in a lexical sub, the cv that + rv2cv_op_cv returns may be a nameless stub. */ + if (!namegv) return ck_entersub_args_list(o); + + } + return ckfun(aTHX_ o, namegv, ckobj); } } @@ -15273,10 +15273,10 @@ Perl_ck_svconst(pTHX_ OP *o) that constant, mark the constant as COWable here, if it is not already read-only. */ if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { - SvIsCOW_on(sv); - CowREFCNT(sv) = 0; + SvIsCOW_on(sv); + CowREFCNT(sv) = 0; # ifdef PERL_DEBUG_READONLY_COW - sv_buf_to_ro(sv); + sv_buf_to_ro(sv); # endif } #endif @@ -15290,20 +15290,20 @@ Perl_ck_trunc(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_TRUNC; if (o->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_NULL) - kid = (SVOP*)OpSIBLING(kid); - if (kid && kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE) && - !kid->op_folded) - { - o->op_flags |= OPf_SPECIAL; - kid->op_private &= ~OPpCONST_STRICT; + SVOP *kid = (SVOP*)cUNOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = (SVOP*)OpSIBLING(kid); + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE) && + !kid->op_folded) + { + o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) { no_bareword_filehandle(SvPVX(cSVOPx_sv(kid))); } - } + } } return ck_fun(o); } @@ -15315,15 +15315,15 @@ Perl_ck_substr(pTHX_ OP *o) o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { - OP *kid = cLISTOPo->op_first; + OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_NULL) - kid = OpSIBLING(kid); - if (kid) - /* Historically, substr(delete $foo{bar},...) has been allowed - with 4-arg substr. Keep it working by applying entersub - lvalue context. */ - op_lvalue(kid, OP_ENTERSUB); + if (kid->op_type == OP_NULL) + kid = OpSIBLING(kid); + if (kid) + /* Historically, substr(delete $foo{bar},...) has been allowed + with 4-arg substr. Keep it working by applying entersub + lvalue context. */ + op_lvalue(kid, OP_ENTERSUB); } return o; @@ -15351,32 +15351,32 @@ Perl_ck_each(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_EACH; if (kid) { - switch (kid->op_type) { - case OP_PADHV: - case OP_RV2HV: - break; - case OP_PADAV: - case OP_RV2AV: + switch (kid->op_type) { + case OP_PADHV: + case OP_RV2HV: + break; + case OP_PADAV: + case OP_RV2AV: OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES); - break; - case OP_CONST: - if (kid->op_private == OPpCONST_BARE - || !SvROK(cSVOPx_sv(kid)) - || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV - && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) - ) - goto bad; + break; + case OP_CONST: + if (kid->op_private == OPpCONST_BARE + || !SvROK(cSVOPx_sv(kid)) + || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV + && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) + ) + goto bad; /* FALLTHROUGH */ - default: + default: qerror(Perl_mess(aTHX_ "Experimental %s on scalar is now forbidden", PL_op_desc[orig_type])); bad: bad_type_pv(1, "hash or array", o, kid); return o; - } + } } return ck_fun(o); } @@ -15400,7 +15400,7 @@ Perl_ck_length(pTHX_ OP *o) case OP_PADAV: case OP_RV2HV: case OP_RV2AV: - name = S_op_varname(aTHX_ kid); + name = S_op_varname(aTHX_ kid); break; default: return o; @@ -15954,19 +15954,19 @@ S_inplace_aassign(pTHX_ OP *o) { modop = OpSIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) - return; + return; /* no other operation except sort/reverse */ if (OpHAS_SIBLING(modop)) - return; + return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { - /* skip sort subroutine/block */ - assert(oright->op_type == OP_NULL); - oright = OpSIBLING(oright); + /* skip sort subroutine/block */ + assert(oright->op_type == OP_NULL); + oright = OpSIBLING(oright); } assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL); @@ -15976,31 +15976,31 @@ S_inplace_aassign(pTHX_ OP *o) { /* Check the lhs is an array */ if (!oleft || - (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || OpHAS_SIBLING(oleft) - || (oleft->op_private & OPpLVAL_INTRO) + (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) + || OpHAS_SIBLING(oleft) + || (oleft->op_private & OPpLVAL_INTRO) ) - return; + return; /* Only one thing on the rhs */ if (OpHAS_SIBLING(oright)) - return; + return; /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { - if (oright->op_type != OP_RV2AV - || !cUNOPx(oright)->op_first - || cUNOPx(oright)->op_first->op_type != OP_GV - || cUNOPx(oleft )->op_first->op_type != OP_GV - || cGVOPx_gv(cUNOPx(oleft)->op_first) != - cGVOPx_gv(cUNOPx(oright)->op_first) - ) - return; + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cUNOPx(oleft )->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return; } else if (oright->op_type != OP_PADAV - || oright->op_targ != oleft->op_targ + || oright->op_targ != oleft->op_targ ) - return; + return; /* This actually is an inplace assignment */ @@ -16013,7 +16013,7 @@ S_inplace_aassign(pTHX_ OP *o) { op_null(o); op_null(oleft_pushmark); if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) - op_null(cUNOPx(oleft)->op_first); + op_null(cUNOPx(oleft)->op_first); op_null(oleft); } @@ -16345,7 +16345,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) if ( o->op_type != OP_AELEM || (o->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) ) maybe_aelemfast = FALSE; @@ -16816,8 +16816,8 @@ S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag) OP **defer = defer_queue[defer_base]; \ CALL_RPEEP(*defer); \ S_prune_chain_head(defer); \ - defer_base = (defer_base + 1) % MAX_DEFERRED; \ - defer_ix--; \ + defer_base = (defer_base + 1) % MAX_DEFERRED; \ + defer_ix--; \ } \ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ } STMT_END @@ -16840,7 +16840,7 @@ Perl_rpeep(pTHX_ OP *o) int defer_ix = -1; if (!o || o->op_opt) - return; + return; assert(o->op_type != OP_FREED); @@ -16848,17 +16848,17 @@ Perl_rpeep(pTHX_ OP *o) SAVEOP(); SAVEVPTR(PL_curcop); for (;; o = o->op_next) { - if (o && o->op_opt) - o = NULL; - if (!o) { - while (defer_ix >= 0) { + if (o && o->op_opt) + o = NULL; + if (!o) { + while (defer_ix >= 0) { OP **defer = defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; CALL_RPEEP(*defer); S_prune_chain_head(defer); } - break; - } + break; + } redo: @@ -16866,10 +16866,10 @@ Perl_rpeep(pTHX_ OP *o) assert(!oldoldop || oldoldop->op_next == oldop); assert(!oldop || oldop->op_next == o); - /* By default, this op has now been optimised. A couple of cases below - clear this again. */ - o->op_opt = 1; - PL_op = o; + /* By default, this op has now been optimised. A couple of cases below + clear this again. */ + o->op_opt = 1; + PL_op = o; /* look for a series of 1 or more aggregate derefs, e.g. * $a[1]{foo}[$i]{$k} @@ -17051,90 +17051,90 @@ Perl_rpeep(pTHX_ OP *o) } - switch (o->op_type) { - case OP_DBSTATE: - PL_curcop = ((COP*)o); /* for warnings */ - break; - case OP_NEXTSTATE: - PL_curcop = ((COP*)o); /* for warnings */ - - /* Optimise a "return ..." at the end of a sub to just be "...". - * This saves 2 ops. Before: - * 1 <;> nextstate(main 1 -e:1) v ->2 - * 4 <@> return K ->5 - * 2 <0> pushmark s ->3 - * - <1> ex-rv2sv sK/1 ->4 - * 3 <#> gvsv[*cat] s ->4 - * - * After: - * - <@> return K ->- - * - <0> pushmark s ->2 - * - <1> ex-rv2sv sK/1 ->- - * 2 <$> gvsv(*cat) s ->3 - */ - { - OP *next = o->op_next; - OP *sibling = OpSIBLING(o); - if ( OP_TYPE_IS(next, OP_PUSHMARK) - && OP_TYPE_IS(sibling, OP_RETURN) - && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) - && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) - ||OP_TYPE_IS(sibling->op_next->op_next, - OP_LEAVESUBLV)) - && cUNOPx(sibling)->op_first == next - && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next - && next->op_next - ) { - /* Look through the PUSHMARK's siblings for one that - * points to the RETURN */ - OP *top = OpSIBLING(next); - while (top && top->op_next) { - if (top->op_next == sibling) { - top->op_next = sibling->op_next; - o->op_next = next->op_next; - break; - } - top = OpSIBLING(top); - } - } - } - - /* Optimise 'my $x; my $y;' into 'my ($x, $y);' + switch (o->op_type) { + case OP_DBSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + break; + case OP_NEXTSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + + /* Optimise a "return ..." at the end of a sub to just be "...". + * This saves 2 ops. Before: + * 1 <;> nextstate(main 1 -e:1) v ->2 + * 4 <@> return K ->5 + * 2 <0> pushmark s ->3 + * - <1> ex-rv2sv sK/1 ->4 + * 3 <#> gvsv[*cat] s ->4 + * + * After: + * - <@> return K ->- + * - <0> pushmark s ->2 + * - <1> ex-rv2sv sK/1 ->- + * 2 <$> gvsv(*cat) s ->3 + */ + { + OP *next = o->op_next; + OP *sibling = OpSIBLING(o); + if ( OP_TYPE_IS(next, OP_PUSHMARK) + && OP_TYPE_IS(sibling, OP_RETURN) + && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) + && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) + ||OP_TYPE_IS(sibling->op_next->op_next, + OP_LEAVESUBLV)) + && cUNOPx(sibling)->op_first == next + && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = OpSIBLING(next); + while (top && top->op_next) { + if (top->op_next == sibling) { + top->op_next = sibling->op_next; + o->op_next = next->op_next; + break; + } + top = OpSIBLING(top); + } + } + } + + /* Optimise 'my $x; my $y;' into 'my ($x, $y);' * - * This latter form is then suitable for conversion into padrange - * later on. Convert: - * - * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 - * - * into: - * - * nextstate1 -> listop -> nextstate3 - * / \ - * pushmark -> padop1 -> padop2 - */ - if (o->op_next && ( - o->op_next->op_type == OP_PADSV - || o->op_next->op_type == OP_PADAV - || o->op_next->op_type == OP_PADHV - ) - && !(o->op_next->op_private & ~OPpLVAL_INTRO) - && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE - && o->op_next->op_next->op_next && ( - o->op_next->op_next->op_next->op_type == OP_PADSV - || o->op_next->op_next->op_next->op_type == OP_PADAV - || o->op_next->op_next->op_next->op_type == OP_PADHV - ) - && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) - && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE - && (!CopLABEL((COP*)o)) /* Don't mess with labels */ - && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ - ) { - OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; - - pad1 = o->op_next; - ns2 = pad1->op_next; - pad2 = ns2->op_next; - ns3 = pad2->op_next; + * This latter form is then suitable for conversion into padrange + * later on. Convert: + * + * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 + * + * into: + * + * nextstate1 -> listop -> nextstate3 + * / \ + * pushmark -> padop1 -> padop2 + */ + if (o->op_next && ( + o->op_next->op_type == OP_PADSV + || o->op_next->op_type == OP_PADAV + || o->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE + && o->op_next->op_next->op_next && ( + o->op_next->op_next->op_next->op_type == OP_PADSV + || o->op_next->op_next->op_next->op_type == OP_PADAV + || o->op_next->op_next->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE + && (!CopLABEL((COP*)o)) /* Don't mess with labels */ + && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ + ) { + OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; + + pad1 = o->op_next; + ns2 = pad1->op_next; + pad2 = ns2->op_next; + ns3 = pad2->op_next; /* we assume here that the op_next chain is the same as * the op_sibling chain */ @@ -17152,35 +17152,35 @@ Perl_rpeep(pTHX_ OP *o) /* create new listop, with children consisting of: * a new pushmark, pad1, pad2. */ - newop = newLISTOP(OP_LIST, 0, pad1, pad2); - newop->op_flags |= OPf_PARENS; - newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + newop = newLISTOP(OP_LIST, 0, pad1, pad2); + newop->op_flags |= OPf_PARENS; + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; /* insert newop between o and ns3 */ op_sibling_splice(NULL, o, 0, newop); /*fixup op_next chain */ newpm = cUNOPx(newop)->op_first; /* pushmark */ - o ->op_next = newpm; - newpm->op_next = pad1; - pad1 ->op_next = pad2; - pad2 ->op_next = newop; /* listop */ - newop->op_next = ns3; - - /* Ensure pushmark has this flag if padops do */ - if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { - newpm->op_flags |= OPf_MOD; - } - - break; - } - - /* Two NEXTSTATEs in a row serve no purpose. Except if they happen - to carry two labels. For now, take the easier option, and skip - this optimisation if the first NEXTSTATE has a label. */ - if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { - OP *nextop = o->op_next; - while (nextop) { + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + /* Ensure pushmark has this flag if padops do */ + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { + newpm->op_flags |= OPf_MOD; + } + + break; + } + + /* Two NEXTSTATEs in a row serve no purpose. Except if they happen + to carry two labels. For now, take the easier option, and skip + this optimisation if the first NEXTSTATE has a label. */ + if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { + OP *nextop = o->op_next; + while (nextop) { switch (nextop->op_type) { case OP_NULL: case OP_SCALAR: @@ -17192,61 +17192,61 @@ Perl_rpeep(pTHX_ OP *o) break; } - if (nextop && (nextop->op_type == OP_NEXTSTATE)) { - op_null(o); - if (oldop) - oldop->op_next = nextop; + if (nextop && (nextop->op_type == OP_NEXTSTATE)) { + op_null(o); + if (oldop) + oldop->op_next = nextop; o = nextop; - /* Skip (old)oldop assignment since the current oldop's - op_next already points to the next op. */ - goto redo; - } - } - break; - - case OP_CONCAT: - if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { - if (o->op_next->op_private & OPpTARGET_MY) { - if (o->op_flags & OPf_STACKED) /* chained concats */ - break; /* ignore_optimization */ - else { - /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ - o->op_targ = o->op_next->op_targ; - o->op_next->op_targ = 0; - o->op_private |= OPpTARGET_MY; - } - } - op_null(o->op_next); - } - break; - case OP_STUB: - if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - break; /* Scalar stub must produce undef. List stub is noop */ - } - goto nothin; - case OP_NULL: - if (o->op_targ == OP_NEXTSTATE - || o->op_targ == OP_DBSTATE) - { - PL_curcop = ((COP*)o); - } - /* XXX: We avoid setting op_seq here to prevent later calls - to rpeep() from mistakenly concluding that optimisation - has already occurred. This doesn't fix the real problem, - though (See 20010220.007 (#5874)). AMS 20010719 */ - /* op_seq functionality is now replaced by op_opt */ - o->op_opt = 0; - /* FALLTHROUGH */ - case OP_SCALAR: - case OP_LINESEQ: - case OP_SCOPE: - nothin: - if (oldop) { - oldop->op_next = o->op_next; - o->op_opt = 0; - continue; - } - break; + /* Skip (old)oldop assignment since the current oldop's + op_next already points to the next op. */ + goto redo; + } + } + break; + + case OP_CONCAT: + if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { + if (o->op_next->op_private & OPpTARGET_MY) { + if (o->op_flags & OPf_STACKED) /* chained concats */ + break; /* ignore_optimization */ + else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ + o->op_targ = o->op_next->op_targ; + o->op_next->op_targ = 0; + o->op_private |= OPpTARGET_MY; + } + } + op_null(o->op_next); + } + break; + case OP_STUB: + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { + break; /* Scalar stub must produce undef. List stub is noop */ + } + goto nothin; + case OP_NULL: + if (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE) + { + PL_curcop = ((COP*)o); + } + /* XXX: We avoid setting op_seq here to prevent later calls + to rpeep() from mistakenly concluding that optimisation + has already occurred. This doesn't fix the real problem, + though (See 20010220.007 (#5874)). AMS 20010719 */ + /* op_seq functionality is now replaced by op_opt */ + o->op_opt = 0; + /* FALLTHROUGH */ + case OP_SCALAR: + case OP_LINESEQ: + case OP_SCOPE: + nothin: + if (oldop) { + oldop->op_next = o->op_next; + o->op_opt = 0; + continue; + } + break; case OP_PUSHMARK: @@ -17541,13 +17541,13 @@ Perl_rpeep(pTHX_ OP *o) break; } - case OP_RV2AV: + case OP_RV2AV: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); break; - case OP_RV2HV: - case OP_PADHV: + case OP_RV2HV: + case OP_PADHV: /*'keys %h' in void or scalar context: skip the OP_KEYS * and perform the functionality directly in the RV2HV/PADHV * op @@ -17583,13 +17583,13 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_type != OP_PADHV) break; /* FALLTHROUGH */ - case OP_PADAV: + case OP_PADAV: if ( o->op_type == OP_PADAV && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR ) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); /* FALLTHROUGH */ - case OP_PADSV: + case OP_PADSV: /* Skip over state($x) in void context. */ if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) @@ -17600,174 +17600,174 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_type != OP_PADAV) break; /* FALLTHROUGH */ - case OP_GV: - if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { - OP* const pop = (o->op_type == OP_PADAV) ? - o->op_next : o->op_next->op_next; - IV i; - if (pop && pop->op_type == OP_CONST && - ((PL_op = pop->op_next)) && - pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) - { - GV *gv; - if (cSVOPx(pop)->op_private & OPpCONST_STRICT) - no_bareword_allowed(pop); - if (o->op_type == OP_GV) - op_null(o->op_next); - op_null(pop->op_next); - op_null(pop); - o->op_flags |= pop->op_next->op_flags & OPf_MOD; - o->op_next = pop->op_next->op_next; - o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; - o->op_private = (U8)i; - if (o->op_type == OP_GV) { - gv = cGVOPo_gv; - GvAVn(gv); - o->op_type = OP_AELEMFAST; - } - else - o->op_type = OP_AELEMFAST_LEX; - } - if (o->op_type != OP_GV) - break; - } - - /* Remove $foo from the op_next chain in void context. */ - if (oldop - && ( o->op_next->op_type == OP_RV2SV - || o->op_next->op_type == OP_RV2AV - || o->op_next->op_type == OP_RV2HV ) - && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID - && !(o->op_next->op_private & OPpLVAL_INTRO)) - { - oldop->op_next = o->op_next->op_next; - /* Reprocess the previous op if it is a nextstate, to - allow double-nextstate optimisation. */ - redo_nextstate: - if (oldop->op_type == OP_NEXTSTATE) { - oldop->op_opt = 0; - o = oldop; - oldop = oldoldop; - oldoldop = NULL; - goto redo; - } - o = oldop->op_next; + case OP_GV: + if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { + OP* const pop = (o->op_type == OP_PADAV) ? + o->op_next : o->op_next->op_next; + IV i; + if (pop && pop->op_type == OP_CONST && + ((PL_op = pop->op_next)) && + pop->op_next->op_type == OP_AELEM && + !(pop->op_next->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && + (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) + { + GV *gv; + if (cSVOPx(pop)->op_private & OPpCONST_STRICT) + no_bareword_allowed(pop); + if (o->op_type == OP_GV) + op_null(o->op_next); + op_null(pop->op_next); + op_null(pop); + o->op_flags |= pop->op_next->op_flags & OPf_MOD; + o->op_next = pop->op_next->op_next; + o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; + o->op_private = (U8)i; + if (o->op_type == OP_GV) { + gv = cGVOPo_gv; + GvAVn(gv); + o->op_type = OP_AELEMFAST; + } + else + o->op_type = OP_AELEMFAST_LEX; + } + if (o->op_type != OP_GV) + break; + } + + /* Remove $foo from the op_next chain in void context. */ + if (oldop + && ( o->op_next->op_type == OP_RV2SV + || o->op_next->op_type == OP_RV2AV + || o->op_next->op_type == OP_RV2HV ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + && !(o->op_next->op_private & OPpLVAL_INTRO)) + { + oldop->op_next = o->op_next->op_next; + /* Reprocess the previous op if it is a nextstate, to + allow double-nextstate optimisation. */ + redo_nextstate: + if (oldop->op_type == OP_NEXTSTATE) { + oldop->op_opt = 0; + o = oldop; + oldop = oldoldop; + oldoldop = NULL; + goto redo; + } + o = oldop->op_next; goto redo; - } - else if (o->op_next->op_type == OP_RV2SV) { - if (!(o->op_next->op_private & OPpDEREF)) { - op_null(o->op_next); - o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO - | OPpOUR_INTRO); - o->op_next = o->op_next->op_next; + } + else if (o->op_next->op_type == OP_RV2SV) { + if (!(o->op_next->op_private & OPpDEREF)) { + op_null(o->op_next); + o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO + | OPpOUR_INTRO); + o->op_next = o->op_next->op_next; OpTYPE_set(o, OP_GVSV); - } - } - else if (o->op_next->op_type == OP_READLINE - && o->op_next->op_next->op_type == OP_CONCAT - && (o->op_next->op_next->op_flags & OPf_STACKED)) - { - /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ + } + } + else if (o->op_next->op_type == OP_READLINE + && o->op_next->op_next->op_type == OP_CONCAT + && (o->op_next->op_next->op_flags & OPf_STACKED)) + { + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ OpTYPE_set(o, OP_RCATLINE); - o->op_flags |= OPf_STACKED; - op_null(o->op_next->op_next); - op_null(o->op_next); - } + o->op_flags |= OPf_STACKED; + op_null(o->op_next->op_next); + op_null(o->op_next); + } - break; + break; case OP_NOT: break; case OP_AND: - case OP_OR: - case OP_DOR: - case OP_CMPCHAIN_AND: - while (cLOGOP->op_other->op_type == OP_NULL) - cLOGOP->op_other = cLOGOP->op_other->op_next; - while (o->op_next && ( o->op_type == o->op_next->op_type - || o->op_next->op_type == OP_NULL)) - o->op_next = o->op_next->op_next; - - /* If we're an OR and our next is an AND in void context, we'll - follow its op_other on short circuit, same for reverse. - We can't do this with OP_DOR since if it's true, its return - value is the underlying value which must be evaluated - by the next op. */ - if (o->op_next && - ( - (IS_AND_OP(o) && IS_OR_OP(o->op_next)) - || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) - ) - && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID - ) { - o->op_next = ((LOGOP*)o->op_next)->op_other; - } - DEFER(cLOGOP->op_other); - o->op_opt = 1; - break; - - case OP_GREPWHILE: + case OP_OR: + case OP_DOR: + case OP_CMPCHAIN_AND: + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + while (o->op_next && ( o->op_type == o->op_next->op_type + || o->op_next->op_type == OP_NULL)) + o->op_next = o->op_next->op_next; + + /* If we're an OR and our next is an AND in void context, we'll + follow its op_other on short circuit, same for reverse. + We can't do this with OP_DOR since if it's true, its return + value is the underlying value which must be evaluated + by the next op. */ + if (o->op_next && + ( + (IS_AND_OP(o) && IS_OR_OP(o->op_next)) + || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) + ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + ) { + o->op_next = ((LOGOP*)o->op_next)->op_other; + } + DEFER(cLOGOP->op_other); + o->op_opt = 1; + break; + + case OP_GREPWHILE: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); /* FALLTHROUGH */ - case OP_COND_EXPR: - case OP_MAPWHILE: - case OP_ANDASSIGN: - case OP_ORASSIGN: - case OP_DORASSIGN: - case OP_RANGE: - case OP_ONCE: - case OP_ARGDEFELEM: - while (cLOGOP->op_other->op_type == OP_NULL) - cLOGOP->op_other = cLOGOP->op_other->op_next; - DEFER(cLOGOP->op_other); - break; - - case OP_ENTERLOOP: - case OP_ENTERITER: - while (cLOOP->op_redoop->op_type == OP_NULL) - cLOOP->op_redoop = cLOOP->op_redoop->op_next; - while (cLOOP->op_nextop->op_type == OP_NULL) - cLOOP->op_nextop = cLOOP->op_nextop->op_next; - while (cLOOP->op_lastop->op_type == OP_NULL) - cLOOP->op_lastop = cLOOP->op_lastop->op_next; - /* a while(1) loop doesn't have an op_next that escapes the - * loop, so we have to explicitly follow the op_lastop to - * process the rest of the code */ - DEFER(cLOOP->op_lastop); - break; + case OP_COND_EXPR: + case OP_MAPWHILE: + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: + case OP_RANGE: + case OP_ONCE: + case OP_ARGDEFELEM: + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + DEFER(cLOGOP->op_other); + break; + + case OP_ENTERLOOP: + case OP_ENTERITER: + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; + /* a while(1) loop doesn't have an op_next that escapes the + * loop, so we have to explicitly follow the op_lastop to + * process the rest of the code */ + DEFER(cLOOP->op_lastop); + break; case OP_ENTERTRY: - assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); - DEFER(cLOGOPo->op_other); - break; + assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); + DEFER(cLOGOPo->op_other); + break; - case OP_SUBST: + case OP_SUBST: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); - assert(!(cPMOP->op_pmflags & PMf_ONCE)); - while (cPMOP->op_pmstashstartu.op_pmreplstart && - cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) - cPMOP->op_pmstashstartu.op_pmreplstart - = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; - DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); - break; - - case OP_SORT: { - OP *oright; - - if (o->op_flags & OPf_SPECIAL) { + assert(!(cPMOP->op_pmflags & PMf_ONCE)); + while (cPMOP->op_pmstashstartu.op_pmreplstart && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); + break; + + case OP_SORT: { + OP *oright; + + if (o->op_flags & OPf_SPECIAL) { /* first arg is a code block */ OP * const nullop = OpSIBLING(cLISTOP->op_first); OP * kid = cUNOPx(nullop)->op_first; assert(nullop->op_type == OP_NULL); - assert(kid->op_type == OP_SCOPE - || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); + assert(kid->op_type == OP_SCOPE + || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); /* since OP_SORT doesn't have a handy op_other-style * field that can point directly to the start of the code * block, store it in the otherwise-unused op_next field @@ -17785,167 +17785,167 @@ Perl_rpeep(pTHX_ OP *o) || (PL_parser && PL_parser->error_count)); nullop->op_next = kid->op_next; DEFER(nullop->op_next); - } - - /* check that RHS of sort is a single plain array */ - oright = cUNOPo->op_first; - if (!oright || oright->op_type != OP_PUSHMARK) - break; - - if (o->op_private & OPpSORT_INPLACE) - break; - - /* reverse sort ... can be optimised. */ - if (!OpHAS_SIBLING(cUNOPo)) { - /* Nothing follows us on the list. */ - OP * const reverse = o->op_next; - - if (reverse->op_type == OP_REVERSE && - (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { - OP * const pushmark = cUNOPx(reverse)->op_first; - if (pushmark && (pushmark->op_type == OP_PUSHMARK) - && (OpSIBLING(cUNOPx(pushmark)) == o)) { - /* reverse -> pushmark -> sort */ - o->op_private |= OPpSORT_REVERSE; - op_null(reverse); - pushmark->op_next = oright->op_next; - op_null(oright); - } - } - } - - break; - } - - case OP_REVERSE: { - OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; - OP *gvop = NULL; - LISTOP *enter, *exlist; - - if (o->op_private & OPpSORT_INPLACE) - break; - - enter = (LISTOP *) o->op_next; - if (!enter) - break; - if (enter->op_type == OP_NULL) { - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - } - /* for $a (...) will have OP_GV then OP_RV2GV here. - for (...) just has an OP_GV. */ - if (enter->op_type == OP_GV) { - gvop = (OP *) enter; - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - if (enter->op_type == OP_RV2GV) { - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - } - } - - if (enter->op_type != OP_ENTERITER) - break; - - iter = enter->op_next; - if (!iter || iter->op_type != OP_ITER) - break; - - expushmark = enter->op_first; - if (!expushmark || expushmark->op_type != OP_NULL - || expushmark->op_targ != OP_PUSHMARK) - break; - - exlist = (LISTOP *) OpSIBLING(expushmark); - if (!exlist || exlist->op_type != OP_NULL - || exlist->op_targ != OP_LIST) - break; - - if (exlist->op_last != o) { - /* Mmm. Was expecting to point back to this op. */ - break; - } - theirmark = exlist->op_first; - if (!theirmark || theirmark->op_type != OP_PUSHMARK) - break; - - if (OpSIBLING(theirmark) != o) { - /* There's something between the mark and the reverse, eg - for (1, reverse (...)) - so no go. */ - break; - } - - ourmark = ((LISTOP *)o)->op_first; - if (!ourmark || ourmark->op_type != OP_PUSHMARK) - break; - - ourlast = ((LISTOP *)o)->op_last; - if (!ourlast || ourlast->op_next != o) - break; - - rv2av = OpSIBLING(ourmark); - if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) - && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { - /* We're just reversing a single array. */ - rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; - enter->op_flags |= OPf_STACKED; - } - - /* We don't have control over who points to theirmark, so sacrifice - ours. */ - theirmark->op_next = ourmark->op_next; - theirmark->op_flags = ourmark->op_flags; - ourlast->op_next = gvop ? gvop : (OP *) enter; - op_null(ourmark); - op_null(o); - enter->op_private |= OPpITER_REVERSED; - iter->op_private |= OPpITER_REVERSED; + } + + /* check that RHS of sort is a single plain array */ + oright = cUNOPo->op_first; + if (!oright || oright->op_type != OP_PUSHMARK) + break; + + if (o->op_private & OPpSORT_INPLACE) + break; + + /* reverse sort ... can be optimised. */ + if (!OpHAS_SIBLING(cUNOPo)) { + /* Nothing follows us on the list. */ + OP * const reverse = o->op_next; + + if (reverse->op_type == OP_REVERSE && + (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { + OP * const pushmark = cUNOPx(reverse)->op_first; + if (pushmark && (pushmark->op_type == OP_PUSHMARK) + && (OpSIBLING(cUNOPx(pushmark)) == o)) { + /* reverse -> pushmark -> sort */ + o->op_private |= OPpSORT_REVERSE; + op_null(reverse); + pushmark->op_next = oright->op_next; + op_null(oright); + } + } + } + + break; + } + + case OP_REVERSE: { + OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; + OP *gvop = NULL; + LISTOP *enter, *exlist; + + if (o->op_private & OPpSORT_INPLACE) + break; + + enter = (LISTOP *) o->op_next; + if (!enter) + break; + if (enter->op_type == OP_NULL) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + /* for $a (...) will have OP_GV then OP_RV2GV here. + for (...) just has an OP_GV. */ + if (enter->op_type == OP_GV) { + gvop = (OP *) enter; + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + if (enter->op_type == OP_RV2GV) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + } + + if (enter->op_type != OP_ENTERITER) + break; + + iter = enter->op_next; + if (!iter || iter->op_type != OP_ITER) + break; + + expushmark = enter->op_first; + if (!expushmark || expushmark->op_type != OP_NULL + || expushmark->op_targ != OP_PUSHMARK) + break; + + exlist = (LISTOP *) OpSIBLING(expushmark); + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_last != o) { + /* Mmm. Was expecting to point back to this op. */ + break; + } + theirmark = exlist->op_first; + if (!theirmark || theirmark->op_type != OP_PUSHMARK) + break; + + if (OpSIBLING(theirmark) != o) { + /* There's something between the mark and the reverse, eg + for (1, reverse (...)) + so no go. */ + break; + } + + ourmark = ((LISTOP *)o)->op_first; + if (!ourmark || ourmark->op_type != OP_PUSHMARK) + break; + + ourlast = ((LISTOP *)o)->op_last; + if (!ourlast || ourlast->op_next != o) + break; + + rv2av = OpSIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) + && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { + /* We're just reversing a single array. */ + rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; + enter->op_flags |= OPf_STACKED; + } + + /* We don't have control over who points to theirmark, so sacrifice + ours. */ + theirmark->op_next = ourmark->op_next; + theirmark->op_flags = ourmark->op_flags; + ourlast->op_next = gvop ? gvop : (OP *) enter; + op_null(ourmark); + op_null(o); + enter->op_private |= OPpITER_REVERSED; + iter->op_private |= OPpITER_REVERSED; oldoldop = NULL; oldop = ourlast; o = oldop->op_next; goto redo; NOT_REACHED; /* NOTREACHED */ - break; - } - - case OP_QR: - case OP_MATCH: - if (!(cPMOP->op_pmflags & PMf_ONCE)) { - assert (!cPMOP->op_pmstashstartu.op_pmreplstart); - } - break; - - case OP_RUNCV: - if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) - && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) - { - SV *sv; - if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; - else { - sv = newRV((SV *)PL_compcv); - sv_rvweaken(sv); - SvREADONLY_on(sv); - } + break; + } + + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } + break; + + case OP_RUNCV: + if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) + && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) + { + SV *sv; + if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; + else { + sv = newRV((SV *)PL_compcv); + sv_rvweaken(sv); + SvREADONLY_on(sv); + } OpTYPE_set(o, OP_CONST); - o->op_flags |= OPf_SPECIAL; - cSVOPo->op_sv = sv; - } - break; - - case OP_SASSIGN: - if (OP_GIMME(o,0) == G_VOID - || ( o->op_next->op_type == OP_LINESEQ - && ( o->op_next->op_next->op_type == OP_LEAVESUB - || ( o->op_next->op_next->op_type == OP_RETURN - && !CvLVALUE(PL_compcv))))) - { - OP *right = cBINOP->op_first; - if (right) { + o->op_flags |= OPf_SPECIAL; + cSVOPo->op_sv = sv; + } + break; + + case OP_SASSIGN: + if (OP_GIMME(o,0) == G_VOID + || ( o->op_next->op_type == OP_LINESEQ + && ( o->op_next->op_next->op_type == OP_LEAVESUB + || ( o->op_next->op_next->op_type == OP_RETURN + && !CvLVALUE(PL_compcv))))) + { + OP *right = cBINOP->op_first; + if (right) { /* sassign * RIGHT * substr @@ -17963,24 +17963,24 @@ Perl_rpeep(pTHX_ OP *o) * arg2 * ... */ - OP *left = OpSIBLING(right); - if (left->op_type == OP_SUBSTR - && (left->op_private & 7) < 4) { - op_null(o); + OP *left = OpSIBLING(right); + if (left->op_type == OP_SUBSTR + && (left->op_private & 7) < 4) { + op_null(o); /* cut out right */ op_sibling_splice(o, NULL, 1, NULL); /* and insert it as second child of OP_SUBSTR */ op_sibling_splice(left, cBINOPx(left)->op_first, 0, right); - left->op_private |= OPpSUBSTR_REPL_FIRST; - left->op_flags = - (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - } - } - } - break; - - case OP_AASSIGN: { + left->op_private |= OPpSUBSTR_REPL_FIRST; + left->op_flags = + (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + } + } + } + break; + + case OP_AASSIGN: { int l, r, lr, lscalars, rscalars; /* handle common vars detection, e.g. ($a,$b) = ($b,$a). @@ -18084,7 +18084,7 @@ Perl_rpeep(pTHX_ OP *o) if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0); - break; + break; } case OP_REF: @@ -18108,15 +18108,15 @@ Perl_rpeep(pTHX_ OP *o) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); break; - case OP_CUSTOM: { - Perl_cpeep_t cpeep = - XopENTRYCUSTOM(o, xop_peep); - if (cpeep) - cpeep(aTHX_ o, oldop); - break; - } + case OP_CUSTOM: { + Perl_cpeep_t cpeep = + XopENTRYCUSTOM(o, xop_peep); + if (cpeep) + cpeep(aTHX_ o, oldop); + break; + } - } + } /* did we just null the current op? If so, re-process it to handle * eliding "empty" ops from the chain */ if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { @@ -18203,7 +18203,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr))); if (PL_custom_ops) - he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); + he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); /* See if the op isn't registered, but its name *is* registered. * That implies someone is using the pre-5.14 API,where only name and @@ -18212,23 +18212,23 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) * We only check for an existing name, and assume no one will have * just registered a desc */ if (!he && PL_custom_op_names && - (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) + (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) ) { - const char *pv; - STRLEN l; - - /* XXX does all this need to be shared mem? */ - Newxz(xop, 1, XOP); - pv = SvPV(HeVAL(he), l); - XopENTRY_set(xop, xop_name, savepvn(pv, l)); - if (PL_custom_op_descs && - (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) - ) { - pv = SvPV(HeVAL(he), l); - XopENTRY_set(xop, xop_desc, savepvn(pv, l)); - } - Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); - he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); + const char *pv; + STRLEN l; + + /* XXX does all this need to be shared mem? */ + Newxz(xop, 1, XOP); + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_name, savepvn(pv, l)); + if (PL_custom_op_descs && + (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) + ) { + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_desc, savepvn(pv, l)); + } + Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); + he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); /* add magic to the SV so that the xop struct (pointed to by * SvIV(sv)) is freed. Normally a static xop is registered, but * for this backcompat hack, we've alloced one */ @@ -18237,60 +18237,60 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) } else { - if (!he) - xop = (XOP *)&xop_null; - else - xop = INT2PTR(XOP *, SvIV(HeVAL(he))); + if (!he) + xop = (XOP *)&xop_null; + else + xop = INT2PTR(XOP *, SvIV(HeVAL(he))); } { - XOPRETANY any; - if(field == XOPe_xop_ptr) { - any.xop_ptr = xop; - } else { - const U32 flags = XopFLAGS(xop); - if(flags & field) { - switch(field) { - case XOPe_xop_name: - any.xop_name = xop->xop_name; - break; - case XOPe_xop_desc: - any.xop_desc = xop->xop_desc; - break; - case XOPe_xop_class: - any.xop_class = xop->xop_class; - break; - case XOPe_xop_peep: - any.xop_peep = xop->xop_peep; - break; - default: + XOPRETANY any; + if(field == XOPe_xop_ptr) { + any.xop_ptr = xop; + } else { + const U32 flags = XopFLAGS(xop); + if(flags & field) { + switch(field) { + case XOPe_xop_name: + any.xop_name = xop->xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = xop->xop_desc; + break; + case XOPe_xop_class: + any.xop_class = xop->xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = xop->xop_peep; + break; + default: field_panic: Perl_croak(aTHX_ "panic: custom_op_get_field(): invalid field %d\n", (int)field); - break; - } - } else { - switch(field) { - case XOPe_xop_name: - any.xop_name = XOPd_xop_name; - break; - case XOPe_xop_desc: - any.xop_desc = XOPd_xop_desc; - break; - case XOPe_xop_class: - any.xop_class = XOPd_xop_class; - break; - case XOPe_xop_peep: - any.xop_peep = XOPd_xop_peep; - break; - default: + break; + } + } else { + switch(field) { + case XOPe_xop_name: + any.xop_name = XOPd_xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = XOPd_xop_desc; + break; + case XOPe_xop_class: + any.xop_class = XOPd_xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = XOPd_xop_peep; + break; + default: goto field_panic; - break; - } - } - } - return any; + break; + } + } + } + return any; } } @@ -18312,10 +18312,10 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) keysv = sv_2mortal(newSViv(PTR2IV(ppaddr))); if (!PL_custom_ops) - PL_custom_ops = newHV(); + PL_custom_ops = newHV(); if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0)) - Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); + Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); } /* @@ -18358,65 +18358,65 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_redo : case KEY_require: case KEY_return: case KEY_say : case KEY_select: case KEY_sort : case KEY_split : case KEY_system: case KEY_x : case KEY_xor : - if (!opnum) return NULL; nullret = TRUE; goto findopnum; + if (!opnum) return NULL; nullret = TRUE; goto findopnum; case KEY_glob: retsetpvs("_;", OP_GLOB); case KEY_keys: retsetpvs("\\[%@]", OP_KEYS); case KEY_values: retsetpvs("\\[%@]", OP_VALUES); case KEY_each: retsetpvs("\\[%@]", OP_EACH); case KEY_pos: retsetpvs(";\\[$*]", OP_POS); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: - retsetpvs("", 0); + retsetpvs("", 0); case KEY_evalbytes: - name = "entereval"; break; + name = "entereval"; break; case KEY_readpipe: - name = "backtick"; + name = "backtick"; } #undef retsetpvs findopnum: while (i < MAXO) { /* The slow way. */ - if (strEQ(name, PL_op_name[i]) - || strEQ(name, PL_op_desc[i])) - { - if (nullret) { assert(opnum); *opnum = i; return NULL; } - goto found; - } - i++; + if (strEQ(name, PL_op_name[i]) + || strEQ(name, PL_op_desc[i])) + { + if (nullret) { assert(opnum); *opnum = i; return NULL; } + goto found; + } + i++; } return NULL; found: defgv = PL_opargs[i] & OA_DEFGV; oa = PL_opargs[i] >> OASHIFT; while (oa) { - if (oa & OA_OPTIONAL && !seen_question && ( - !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF - )) { - seen_question = 1; - str[n++] = ';'; - } - if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF - && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF - /* But globs are already references (kinda) */ - && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF - ) { - str[n++] = '\\'; - } - if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF - && !scalar_mod_type(NULL, i)) { - str[n++] = '['; - str[n++] = '$'; - str[n++] = '@'; - str[n++] = '%'; - if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; - str[n++] = '*'; - str[n++] = ']'; - } - else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; - if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { - str[n-1] = '_'; defgv = 0; - } - oa = oa >> 4; + if (oa & OA_OPTIONAL && !seen_question && ( + !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF + )) { + seen_question = 1; + str[n++] = ';'; + } + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF + /* But globs are already references (kinda) */ + && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF + ) { + str[n++] = '\\'; + } + if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF + && !scalar_mod_type(NULL, i)) { + str[n++] = '['; + str[n++] = '$'; + str[n++] = '@'; + str[n++] = '%'; + if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; + str[n++] = '*'; + str[n++] = ']'; + } + else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; + if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { + str[n-1] = '_'; defgv = 0; + } + oa = oa >> 4; } if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';'; str[n++] = '\0'; @@ -18437,72 +18437,72 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, switch(opnum) { case 0: - return op_append_elem(OP_LINESEQ, - argop, - newSLICEOP(0, - newSVOP(OP_CONST, 0, newSViv(-code % 3)), - newOP(OP_CALLER,0) - ) - ); + return op_append_elem(OP_LINESEQ, + argop, + newSLICEOP(0, + newSVOP(OP_CONST, 0, newSViv(-code % 3)), + newOP(OP_CALLER,0) + ) + ); case OP_EACH: case OP_KEYS: case OP_VALUES: - o = newUNOP(OP_AVHVSWITCH,0,argop); - o->op_private = opnum-OP_EACH; - return o; + o = newUNOP(OP_AVHVSWITCH,0,argop); + o->op_private = opnum-OP_EACH; + return o; case OP_SELECT: /* which represents OP_SSELECT as well */ - if (code) - return newCONDOP( - 0, - newBINOP(OP_GT, 0, - newAVREF(newGVOP(OP_GV, 0, PL_defgv)), - newSVOP(OP_CONST, 0, newSVuv(1)) - ), - coresub_op(newSVuv((UV)OP_SSELECT), 0, - OP_SSELECT), - coresub_op(coreargssv, 0, OP_SELECT) - ); - /* FALLTHROUGH */ + if (code) + return newCONDOP( + 0, + newBINOP(OP_GT, 0, + newAVREF(newGVOP(OP_GV, 0, PL_defgv)), + newSVOP(OP_CONST, 0, newSVuv(1)) + ), + coresub_op(newSVuv((UV)OP_SSELECT), 0, + OP_SSELECT), + coresub_op(coreargssv, 0, OP_SELECT) + ); + /* FALLTHROUGH */ default: - switch (PL_opargs[opnum] & OA_CLASS_MASK) { - case OA_BASEOP: - return op_append_elem( - OP_LINESEQ, argop, - newOP(opnum, - opnum == OP_WANTARRAY || opnum == OP_RUNCV - ? OPpOFFBYONE << 8 : 0) - ); - case OA_BASEOP_OR_UNOP: - if (opnum == OP_ENTEREVAL) { - o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); - if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; - } - else o = newUNOP(opnum,0,argop); - if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; - else { - onearg: - if (is_handle_constructor(o, 1)) - argop->op_private |= OPpCOREARGS_DEREF1; - if (scalar_mod_type(NULL, opnum)) - argop->op_private |= OPpCOREARGS_SCALARMOD; - } - return o; - default: - o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); - if (is_handle_constructor(o, 2)) - argop->op_private |= OPpCOREARGS_DEREF2; - if (opnum == OP_SUBSTR) { - o->op_private |= OPpMAYBE_LVSUB; - return o; - } - else goto onearg; - } + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_BASEOP: + return op_append_elem( + OP_LINESEQ, argop, + newOP(opnum, + opnum == OP_WANTARRAY || opnum == OP_RUNCV + ? OPpOFFBYONE << 8 : 0) + ); + case OA_BASEOP_OR_UNOP: + if (opnum == OP_ENTEREVAL) { + o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); + if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; + } + else o = newUNOP(opnum,0,argop); + if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; + else { + onearg: + if (is_handle_constructor(o, 1)) + argop->op_private |= OPpCOREARGS_DEREF1; + if (scalar_mod_type(NULL, opnum)) + argop->op_private |= OPpCOREARGS_SCALARMOD; + } + return o; + default: + o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); + if (is_handle_constructor(o, 2)) + argop->op_private |= OPpCOREARGS_DEREF2; + if (opnum == OP_SUBSTR) { + o->op_private |= OPpMAYBE_LVSUB; + return o; + } + else goto onearg; + } } } void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, - SV * const *new_const_svp) + SV * const *new_const_svp) { const char *hvname; bool is_const = !!CvCONST(old_cv); @@ -18511,32 +18511,32 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; if (is_const && new_const_svp && old_const_sv == *new_const_svp) - return; - /* They are 2 constant subroutines generated from - the same constant. This probably means that - they are really the "same" proxy subroutine - instantiated in 2 places. Most likely this is - when a constant is exported twice. Don't warn. - */ + return; + /* They are 2 constant subroutines generated from + the same constant. This probably means that + they are really the "same" proxy subroutine + instantiated in 2 places. Most likely this is + when a constant is exported twice. Don't warn. + */ if ( - (ckWARN(WARN_REDEFINE) - && !( - CvGV(old_cv) && GvSTASH(CvGV(old_cv)) - && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 - && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), - strEQ(hvname, "autouse")) - ) - ) + (ckWARN(WARN_REDEFINE) + && !( + CvGV(old_cv) && GvSTASH(CvGV(old_cv)) + && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 + && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), + strEQ(hvname, "autouse")) + ) + ) || (is_const - && ckWARN_d(WARN_REDEFINE) - && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) - ) + && ckWARN_d(WARN_REDEFINE) + && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) + ) ) - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - is_const - ? "Constant subroutine %" SVf " redefined" - : "Subroutine %" SVf " redefined", - SVfARG(name)); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + is_const + ? "Constant subroutine %" SVf " redefined" + : "Subroutine %" SVf " redefined", + SVfARG(name)); } /* @@ -18586,13 +18586,13 @@ something like this: static Perl_check_t nxck_frob; static OP *myck_frob(pTHX_ OP *op) { - ... - op = nxck_frob(aTHX_ op); - ... - return op; + ... + op = nxck_frob(aTHX_ op); + ... + return op; } BOOT: - wrap_op_checker(OP_FROB, myck_frob, &nxck_frob); + wrap_op_checker(OP_FROB, myck_frob, &nxck_frob); If you want to influence compilation of calls to a specific subroutine, then use L rather than hooking checking of @@ -18611,8 +18611,8 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, if (*old_checker_p) return; OP_CHECK_MUTEX_LOCK; if (!*old_checker_p) { - *old_checker_p = PL_check[opcode]; - PL_check[opcode] = new_checker; + *old_checker_p = PL_check[opcode]; + PL_check[opcode] = new_checker; } OP_CHECK_MUTEX_UNLOCK; } @@ -18627,7 +18627,7 @@ const_sv_xsub(pTHX_ CV* cv) SV *const sv = MUTABLE_SV(XSANY.any_ptr); PERL_UNUSED_ARG(items); if (!sv) { - XSRETURN(0); + XSRETURN(0); } EXTEND(sp, 1); ST(0) = sv; @@ -18643,15 +18643,15 @@ const_av_xsub(pTHX_ CV* cv) assert(av); #ifndef DEBUGGING if (!av) { - XSRETURN(0); + XSRETURN(0); } #endif if (SvRMAGICAL(av)) - Perl_croak(aTHX_ "Magical list constants are not supported"); + Perl_croak(aTHX_ "Magical list constants are not supported"); if (GIMME_V != G_ARRAY) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); - XSRETURN(1); + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); + XSRETURN(1); } EXTEND(SP, AvFILLp(av)+1); Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *); diff --git a/perl.c b/perl.c index 48ae9a3a04fd..677004f57b1b 100644 --- a/perl.c +++ b/perl.c @@ -73,9 +73,9 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #define CALL_BODY_SUB(myop) \ if (PL_op == (myop)) \ - PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ + PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ if (PL_op) \ - CALLRUNOPS(aTHX); + CALLRUNOPS(aTHX); #define CALL_LIST_BODY(cv) \ PUSHMARK(PL_stack_sp); \ @@ -85,20 +85,20 @@ static void S_init_tls_and_interp(PerlInterpreter *my_perl) { if (!PL_curinterp) { - PERL_SET_INTERP(my_perl); + PERL_SET_INTERP(my_perl); #if defined(USE_ITHREADS) - INIT_THREADS; - ALLOC_THREAD_KEY; - PERL_SET_THX(my_perl); - OP_REFCNT_INIT; - OP_CHECK_MUTEX_INIT; + INIT_THREADS; + ALLOC_THREAD_KEY; + PERL_SET_THX(my_perl); + OP_REFCNT_INIT; + OP_CHECK_MUTEX_INIT; KEYWORD_PLUGIN_MUTEX_INIT; - HINTS_REFCNT_INIT; + HINTS_REFCNT_INIT; LOCALE_INIT; USER_PROP_MUTEX_INIT; ENV_INIT; - MUTEX_INIT(&PL_dollarzero_mutex); - MUTEX_INIT(&PL_my_ctx_mutex); + MUTEX_INIT(&PL_dollarzero_mutex); + MUTEX_INIT(&PL_my_ctx_mutex); # endif } #if defined(USE_ITHREADS) @@ -107,7 +107,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) /* This always happens for non-ithreads */ #endif { - PERL_SET_THX(my_perl); + PERL_SET_THX(my_perl); } } @@ -141,7 +141,7 @@ void Perl_sys_term(void) { if (!PL_veto_cleanup) { - PERL_SYS_TERM_BODY(); + PERL_SYS_TERM_BODY(); } } @@ -149,10 +149,10 @@ Perl_sys_term(void) #ifdef PERL_IMPLICIT_SYS PerlInterpreter * perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, - struct IPerlMem* ipMP, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { PerlInterpreter *my_perl; @@ -385,7 +385,7 @@ perl_construct(pTHXx) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif - PL_clocktick = HZ; + PL_clocktick = HZ; PL_stashcache = newHV(); @@ -395,16 +395,16 @@ perl_construct(pTHXx) if (!PL_mmap_page_size) { #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) { - SETERRNO(0, SS_NORMAL); + SETERRNO(0, SS_NORMAL); # ifdef _SC_PAGESIZE - PL_mmap_page_size = sysconf(_SC_PAGESIZE); + PL_mmap_page_size = sysconf(_SC_PAGESIZE); # else - PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); + PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); # endif - if ((long) PL_mmap_page_size < 0) { - Perl_croak(aTHX_ "panic: sysconf: %s", - errno ? Strerror(errno) : "pagesize unknown"); - } + if ((long) PL_mmap_page_size < 0) { + Perl_croak(aTHX_ "panic: sysconf: %s", + errno ? Strerror(errno) : "pagesize unknown"); + } } #elif defined(HAS_GETPAGESIZE) PL_mmap_page_size = getpagesize(); @@ -412,8 +412,8 @@ perl_construct(pTHXx) PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ #endif if (PL_mmap_page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - (IV) PL_mmap_page_size); + Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, + (IV) PL_mmap_page_size); } #endif /* HAS_MMAP */ @@ -464,7 +464,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) PERL_ARGS_ASSERT_DUMP_SV_CHILD; if(sock == -1 || debug_fd == -1) - return; + return; PerlIO_flush(Perl_debug_log); @@ -493,12 +493,12 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = sendmsg(sock, &msg, 0); if(got < 0) { - perror("Debug leaking scalars parent sendmsg failed"); - abort(); + perror("Debug leaking scalars parent sendmsg failed"); + abort(); } if(got < sizeof(sv)) { - perror("Debug leaking scalars parent short sendmsg"); - abort(); + perror("Debug leaking scalars parent short sendmsg"); + abort(); } /* Return protocol is @@ -514,35 +514,35 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = readv(sock, vec, 2); if(got < 0) { - perror("Debug leaking scalars parent read failed"); - PerlIO_flush(PerlIO_stderr()); - abort(); + perror("Debug leaking scalars parent read failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); } if(got < sizeof(returned_errno) + 1) { - perror("Debug leaking scalars parent short read"); - PerlIO_flush(PerlIO_stderr()); - abort(); + perror("Debug leaking scalars parent short read"); + PerlIO_flush(PerlIO_stderr()); + abort(); } if (*buffer) { - got = read(sock, buffer + 1, *buffer); - if(got < 0) { - perror("Debug leaking scalars parent read 2 failed"); - PerlIO_flush(PerlIO_stderr()); - abort(); - } + got = read(sock, buffer + 1, *buffer); + if(got < 0) { + perror("Debug leaking scalars parent read 2 failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } - if(got < *buffer) { - perror("Debug leaking scalars parent short read 2"); - PerlIO_flush(PerlIO_stderr()); - abort(); - } + if(got < *buffer) { + perror("Debug leaking scalars parent short read 2"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } } if (returned_errno || *buffer) { - Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" - " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, - returned_errno, Strerror(returned_errno)); + Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" + " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, + returned_errno, Strerror(returned_errno)); } } #endif @@ -601,8 +601,8 @@ perl_destruct(pTHXx) destruct_level = PL_perl_destruct_level; { - const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); - if (s) { + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { int i; if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ i = -1; @@ -613,12 +613,12 @@ perl_destruct(pTHXx) else i = 0; } - if (destruct_level < i) destruct_level = i; + if (destruct_level < i) destruct_level = i; #ifdef PERL_TRACK_MEMPOOL /* RT #114496, for perl_free */ PL_perl_destruct_level = i; #endif - } + } } if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { @@ -626,11 +626,11 @@ perl_destruct(pTHXx) int x = 0; JMPENV_PUSH(x); - PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(x); if (PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); + PERL_SET_PHASE(PERL_PHASE_END); call_list(PL_scopestack_ix, PL_endav); - } + } JMPENV_POP; } LEAVE; @@ -694,161 +694,161 @@ perl_destruct(pTHXx) if (PL_threadhook(aTHX)) { /* Threads hook has vetoed further cleanup */ - PL_veto_cleanup = TRUE; + PL_veto_cleanup = TRUE; return STATUS_EXIT; } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP if (destruct_level != 0) { - /* Fork here to create a child. Our child's job is to preserve the - state of scalars prior to destruction, so that we can instruct it - to dump any scalars that we later find have leaked. - There's no subtlety in this code - it assumes POSIX, and it doesn't - fail gracefully */ - int fd[2]; - - if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { - perror("Debug leaking scalars socketpair failed"); - abort(); - } - - child = fork(); - if(child == -1) { - perror("Debug leaking scalars fork failed"); - abort(); - } - if (!child) { - /* We are the child */ - const int sock = fd[1]; - const int debug_fd = PerlIO_fileno(Perl_debug_log); - int f; - const char *where; - /* Our success message is an integer 0, and a char 0 */ - static const char success[sizeof(int) + 1] = {0}; - - close(fd[0]); - - /* We need to close all other file descriptors otherwise we end up - with interesting hangs, where the parent closes its end of a - pipe, and sits waiting for (another) child to terminate. Only - that child never terminates, because it never gets EOF, because - we also have the far end of the pipe open. We even need to - close the debugging fd, because sometimes it happens to be one - end of a pipe, and a process is waiting on the other end for - EOF. Normally it would be closed at some point earlier in - destruction, but if we happen to cause the pipe to remain open, - EOF never occurs, and we get an infinite hang. Hence all the - games to pass in a file descriptor if it's actually needed. */ - - f = sysconf(_SC_OPEN_MAX); - if(f < 0) { - where = "sysconf failed"; - goto abort; - } - while (f--) { - if (f == sock) - continue; - close(f); - } - - while (1) { - SV *target; - union control_un control; - struct msghdr msg; - struct iovec vec[1]; - struct cmsghdr *cmptr; - ssize_t got; - int got_fd; - - msg.msg_control = control.control; - msg.msg_controllen = sizeof(control.control); - /* We're a connected socket so we don't need a source */ - msg.msg_name = NULL; - msg.msg_namelen = 0; - msg.msg_iov = vec; - msg.msg_iovlen = C_ARRAY_LENGTH(vec); - - vec[0].iov_base = (void*)⌖ - vec[0].iov_len = sizeof(target); + /* Fork here to create a child. Our child's job is to preserve the + state of scalars prior to destruction, so that we can instruct it + to dump any scalars that we later find have leaked. + There's no subtlety in this code - it assumes POSIX, and it doesn't + fail gracefully */ + int fd[2]; + + if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { + perror("Debug leaking scalars socketpair failed"); + abort(); + } + + child = fork(); + if(child == -1) { + perror("Debug leaking scalars fork failed"); + abort(); + } + if (!child) { + /* We are the child */ + const int sock = fd[1]; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + int f; + const char *where; + /* Our success message is an integer 0, and a char 0 */ + static const char success[sizeof(int) + 1] = {0}; + + close(fd[0]); + + /* We need to close all other file descriptors otherwise we end up + with interesting hangs, where the parent closes its end of a + pipe, and sits waiting for (another) child to terminate. Only + that child never terminates, because it never gets EOF, because + we also have the far end of the pipe open. We even need to + close the debugging fd, because sometimes it happens to be one + end of a pipe, and a process is waiting on the other end for + EOF. Normally it would be closed at some point earlier in + destruction, but if we happen to cause the pipe to remain open, + EOF never occurs, and we get an infinite hang. Hence all the + games to pass in a file descriptor if it's actually needed. */ + + f = sysconf(_SC_OPEN_MAX); + if(f < 0) { + where = "sysconf failed"; + goto abort; + } + while (f--) { + if (f == sock) + continue; + close(f); + } + + while (1) { + SV *target; + union control_un control; + struct msghdr msg; + struct iovec vec[1]; + struct cmsghdr *cmptr; + ssize_t got; + int got_fd; + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a source */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = C_ARRAY_LENGTH(vec); + + vec[0].iov_base = (void*)⌖ + vec[0].iov_len = sizeof(target); - got = recvmsg(sock, &msg, 0); - - if(got == 0) - break; - if(got < 0) { - where = "recv failed"; - goto abort; - } - if(got < sizeof(target)) { - where = "short recv"; - goto abort; - } - - if(!(cmptr = CMSG_FIRSTHDR(&msg))) { - where = "no cmsg"; - goto abort; - } - if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { - where = "wrong cmsg_len"; - goto abort; - } - if(cmptr->cmsg_level != SOL_SOCKET) { - where = "wrong cmsg_level"; - goto abort; - } - if(cmptr->cmsg_type != SCM_RIGHTS) { - where = "wrong cmsg_type"; - goto abort; - } - - got_fd = *(int*)CMSG_DATA(cmptr); - /* For our last little bit of trickery, put the file descriptor - back into Perl_debug_log, as if we never actually closed it - */ - if(got_fd != debug_fd) { - if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { - where = "dup2"; - goto abort; - } - } - sv_dump(target); - - PerlIO_flush(Perl_debug_log); - - got = write(sock, &success, sizeof(success)); - - if(got < 0) { - where = "write failed"; - goto abort; - } - if(got < sizeof(success)) { - where = "short write"; - goto abort; - } - } - _exit(0); - abort: - { - int send_errno = errno; - unsigned char length = (unsigned char) strlen(where); - struct iovec failure[3] = { - {(void*)&send_errno, sizeof(send_errno)}, - {&length, 1}, - {(void*)where, length} - }; - int got = writev(sock, failure, 3); - /* Bad news travels fast. Faster than data. We'll get a SIGPIPE - in the parent if we try to read from the socketpair after the - child has exited, even if there was data to read. - So sleep a bit to give the parent a fighting chance of - reading the data. */ - sleep(2); - _exit((got == -1) ? errno : 0); - } - /* End of child. */ - } - PL_dumper_fd = fd[0]; - close(fd[1]); + got = recvmsg(sock, &msg, 0); + + if(got == 0) + break; + if(got < 0) { + where = "recv failed"; + goto abort; + } + if(got < sizeof(target)) { + where = "short recv"; + goto abort; + } + + if(!(cmptr = CMSG_FIRSTHDR(&msg))) { + where = "no cmsg"; + goto abort; + } + if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { + where = "wrong cmsg_len"; + goto abort; + } + if(cmptr->cmsg_level != SOL_SOCKET) { + where = "wrong cmsg_level"; + goto abort; + } + if(cmptr->cmsg_type != SCM_RIGHTS) { + where = "wrong cmsg_type"; + goto abort; + } + + got_fd = *(int*)CMSG_DATA(cmptr); + /* For our last little bit of trickery, put the file descriptor + back into Perl_debug_log, as if we never actually closed it + */ + if(got_fd != debug_fd) { + if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { + where = "dup2"; + goto abort; + } + } + sv_dump(target); + + PerlIO_flush(Perl_debug_log); + + got = write(sock, &success, sizeof(success)); + + if(got < 0) { + where = "write failed"; + goto abort; + } + if(got < sizeof(success)) { + where = "short write"; + goto abort; + } + } + _exit(0); + abort: + { + int send_errno = errno; + unsigned char length = (unsigned char) strlen(where); + struct iovec failure[3] = { + {(void*)&send_errno, sizeof(send_errno)}, + {&length, 1}, + {(void*)where, length} + }; + int got = writev(sock, failure, 3); + /* Bad news travels fast. Faster than data. We'll get a SIGPIPE + in the parent if we try to read from the socketpair after the + child has exited, even if there was data to read. + So sleep a bit to give the parent a fighting chance of + reading the data. */ + sleep(2); + _exit((got == -1) ? errno : 0); + } + /* End of child. */ + } + PL_dumper_fd = fd[0]; + close(fd[1]); } #endif @@ -861,13 +861,13 @@ perl_destruct(pTHXx) op from which the filename structure member is copied. */ PL_curcop = &PL_compiling; if (PL_main_root) { - /* ensure comppad/curpad to refer to main's pad */ - if (CvPADLIST(PL_main_cv)) { - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); - PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); - } - op_free(PL_main_root); - PL_main_root = NULL; + /* ensure comppad/curpad to refer to main's pad */ + if (CvPADLIST(PL_main_cv)) { + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); + } + op_free(PL_main_root); + PL_main_root = NULL; } PL_main_start = NULL; /* note that PL_main_cv isn't usually actually freed at this point, @@ -900,7 +900,7 @@ perl_destruct(pTHXx) /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -917,36 +917,36 @@ perl_destruct(pTHXx) #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) if (environ != PL_origenviron && !PL_use_safe_putenv #ifdef USE_ITHREADS - /* only main thread can free environ[0] contents */ - && PL_curinterp == aTHX + /* only main thread can free environ[0] contents */ + && PL_curinterp == aTHX #endif - ) + ) { - I32 i; + I32 i; - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); - /* Must use safesysfree() when working with environ. */ - safesysfree(environ); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); - environ = PL_origenviron; + environ = PL_origenviron; } #endif #endif /* !PERL_MICRO */ if (destruct_level == 0) { - DEBUG_P(debprofdump()); + DEBUG_P(debprofdump()); #if defined(PERLIO_LAYERS) - /* No more IO - including error messages ! */ - PerlIO_cleanup(aTHX); + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); #endif - CopFILE_free(&PL_compiling); + CopFILE_free(&PL_compiling); - /* The exit() function will do everything that needs doing. */ + /* The exit() function will do everything that needs doing. */ return STATUS_EXIT; } @@ -959,13 +959,13 @@ perl_destruct(pTHXx) * we need to manually ReREFCNT_dec for the clones */ { - I32 i = AvFILLp(PL_regex_padav); - SV **ary = AvARRAY(PL_regex_padav); + I32 i = AvFILLp(PL_regex_padav); + SV **ary = AvARRAY(PL_regex_padav); - for (; i; i--) { - SvREFCNT_dec(ary[i]); - ary[i] = &PL_sv_undef; - } + for (; i; i--) { + SvREFCNT_dec(ary[i]); + ary[i] = &PL_sv_undef; + } } #endif @@ -977,13 +977,13 @@ perl_destruct(pTHXx) /* XXX can PL_parser still be non-null here? */ if(PL_parser && PL_parser->rsfp) { - (void)PerlIO_close(PL_parser->rsfp); - PL_parser->rsfp = NULL; + (void)PerlIO_close(PL_parser->rsfp); + PL_parser->rsfp = NULL; } if (PL_minus_F) { - Safefree(PL_splitstr); - PL_splitstr = NULL; + Safefree(PL_splitstr); + PL_splitstr = NULL; } /* switches */ @@ -1004,8 +1004,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } PL_perldb = 0; @@ -1258,20 +1258,20 @@ perl_destruct(pTHXx) FREETMPS; if (destruct_level >= 2) { - if (PL_scopestack_ix != 0) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", - (long)PL_scopestack_ix); - if (PL_savestack_ix != 0) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced saves: %ld more saves than restores\n", - (long)PL_savestack_ix); - if (PL_tmps_floor != -1) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", - (long)PL_tmps_floor + 1); - if (cxstack_ix != -1) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", - (long)cxstack_ix + 1); + if (PL_scopestack_ix != 0) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)PL_scopestack_ix); + if (PL_savestack_ix != 0) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced saves: %ld more saves than restores\n", + (long)PL_savestack_ix); + if (PL_tmps_floor != -1) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", + (long)PL_tmps_floor + 1); + if (cxstack_ix != -1) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } #ifdef USE_ITHREADS @@ -1290,7 +1290,7 @@ perl_destruct(pTHXx) /* the 2 is for PL_fdpid and PL_strtab */ while (sv_clean_all() > 2) - ; + ; #ifdef USE_ITHREADS Safefree(PL_stashpad); /* must come after sv_clean_all */ @@ -1312,36 +1312,36 @@ perl_destruct(pTHXx) /* Destruct the global string table. */ { - /* Yell and reset the HeVAL() slots that are still holding refcounts, - * so that sv_free() won't fail on them. - * Now that the global string table is using a single hunk of memory - * for both HE and HEK, we either need to explicitly unshare it the - * correct way, or actually free things here. - */ - I32 riter = 0; - const I32 max = HvMAX(PL_strtab); - HE * const * const array = HvARRAY(PL_strtab); - HE *hent = array[0]; - - for (;;) { - if (hent && ckWARN_d(WARN_INTERNAL)) { - HE * const next = HeNEXT(hent); - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced string table refcount: (%ld) for \"%s\"", - (long)hent->he_valu.hent_refcount, HeKEY(hent)); - Safefree(hent); - hent = next; - } - if (!hent) { - if (++riter > max) - break; - hent = array[riter]; - } - } - - Safefree(array); - HvARRAY(PL_strtab) = 0; - HvTOTALKEYS(PL_strtab) = 0; + /* Yell and reset the HeVAL() slots that are still holding refcounts, + * so that sv_free() won't fail on them. + * Now that the global string table is using a single hunk of memory + * for both HE and HEK, we either need to explicitly unshare it the + * correct way, or actually free things here. + */ + I32 riter = 0; + const I32 max = HvMAX(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); + HE *hent = array[0]; + + for (;;) { + if (hent && ckWARN_d(WARN_INTERNAL)) { + HE * const next = HeNEXT(hent); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced string table refcount: (%ld) for \"%s\"", + (long)hent->he_valu.hent_refcount, HeKEY(hent)); + Safefree(hent); + hent = next; + } + if (!hent) { + if (++riter > max) + break; + hent = array[riter]; + } + } + + Safefree(array); + HvARRAY(PL_strtab) = 0; + HvTOTALKEYS(PL_strtab) = 0; } SvREFCNT_dec(PL_strtab); @@ -1379,62 +1379,62 @@ perl_destruct(pTHXx) } if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); #ifdef DEBUG_LEAKING_SCALARS if (PL_sv_count != 0) { - SV* sva; - SV* sv; - SV* svend; - - for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - svend = &sva[SvREFCNT(sva)]; - for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != (svtype)SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" - " flags=0x%" UVxf - " refcnt=%" UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" - "serial %" UVuf "\n", - (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt - pTHX__VALUE, - sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", - sv->sv_debug_line, - sv->sv_debug_inpad ? "for" : "by", - sv->sv_debug_optype ? - PL_op_name[sv->sv_debug_optype]: "(none)", - PTR2UV(sv->sv_debug_parent), - sv->sv_debug_serial - ); + SV* sva; + SV* sv; + SV* svend; + + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != (svtype)SVTYPEMASK) { + PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" + " flags=0x%" UVxf + " refcnt=%" UVuf pTHX__FORMAT "\n" + "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" + "serial %" UVuf "\n", + (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt + pTHX__VALUE, + sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? + PL_op_name[sv->sv_debug_optype]: "(none)", + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial + ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - Perl_dump_sv_child(aTHX_ sv); + Perl_dump_sv_child(aTHX_ sv); #endif - } - } - } + } + } + } } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP { - int status; - fd_set rset; - /* Wait for up to 4 seconds for child to terminate. - This seems to be the least effort way of timing out on reaping - its exit status. */ - struct timeval waitfor = {4, 0}; - int sock = PL_dumper_fd; + int status; + fd_set rset; + /* Wait for up to 4 seconds for child to terminate. + This seems to be the least effort way of timing out on reaping + its exit status. */ + struct timeval waitfor = {4, 0}; + int sock = PL_dumper_fd; - shutdown(sock, 1); - FD_ZERO(&rset); - FD_SET(sock, &rset); - select(sock + 1, &rset, NULL, NULL, &waitfor); - waitpid(child, &status, WNOHANG); - close(sock); + shutdown(sock, 1); + FD_ZERO(&rset); + FD_SET(sock, &rset); + select(sock + 1, &rset, NULL, NULL, &waitfor); + waitpid(child, &status, WNOHANG); + close(sock); } #endif #endif #ifdef DEBUG_LEAKING_SCALARS_ABORT if (PL_sv_count) - abort(); + abort(); #endif PL_sv_count = 0; @@ -1459,11 +1459,11 @@ perl_destruct(pTHXx) PL_psig_name = (SV**)NULL; PL_psig_ptr = (SV**)NULL; { - /* We need to NULL PL_psig_pend first, so that - signal handlers know not to use it */ - int *psig_save = PL_psig_pend; - PL_psig_pend = (int*)NULL; - Safefree(psig_save); + /* We need to NULL PL_psig_pend first, so that + signal handlers know not to use it */ + int *psig_save = PL_psig_pend; + PL_psig_pend = (int*)NULL; + Safefree(psig_save); } nuke_stacks(); TAINTING_set(FALSE); @@ -1488,32 +1488,32 @@ perl_destruct(pTHXx) sv_free_arenas(); while (PL_regmatch_slab) { - regmatch_slab *s = PL_regmatch_slab; - PL_regmatch_slab = PL_regmatch_slab->next; - Safefree(s); + regmatch_slab *s = PL_regmatch_slab; + PL_regmatch_slab = PL_regmatch_slab->next; + Safefree(s); } /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { - /* we know that type == SVt_PVMG */ - - /* it could have accumulated taint magic */ - MAGIC* mg; - MAGIC* moremagic; - for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { - moremagic = mg->mg_moremagic; - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global - && mg->mg_len >= 0) - Safefree(mg->mg_ptr); - Safefree(mg); - } - - /* we know that type >= SVt_PV */ - SvPV_free(PL_mess_sv); - Safefree(SvANY(PL_mess_sv)); - Safefree(PL_mess_sv); - PL_mess_sv = NULL; + /* we know that type == SVt_PVMG */ + + /* it could have accumulated taint magic */ + MAGIC* mg; + MAGIC* moremagic; + for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { + moremagic = mg->mg_moremagic; + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global + && mg->mg_len >= 0) + Safefree(mg->mg_ptr); + Safefree(mg); + } + + /* we know that type >= SVt_PV */ + SvPV_free(PL_mess_sv); + Safefree(SvANY(PL_mess_sv)); + Safefree(PL_mess_sv); + PL_mess_sv = NULL; } return STATUS_EXIT; } @@ -1533,30 +1533,30 @@ perl_free(pTHXx) PERL_ARGS_ASSERT_PERL_FREE; if (PL_veto_cleanup) - return; + return; #ifdef PERL_TRACK_MEMPOOL { - /* - * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero - * value as we're probably hunting memory leaks then - */ - if (PL_perl_destruct_level == 0) { - const U32 old_debug = PL_debug; - /* Emulate the PerlHost behaviour of free()ing all memory allocated in this - thread at thread exit. */ - if (DEBUG_m_TEST) { - PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " - "free this thread's memory\n"); - PL_debug &= ~ DEBUG_m_FLAG; - } - while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ - char * next = (char *)(aTHXx->Imemory_debug_header.next); - Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; - safesysfree(ptr); - } - PL_debug = old_debug; - } + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + if (PL_perl_destruct_level == 0) { + const U32 old_debug = PL_debug; + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + if (DEBUG_m_TEST) { + PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " + "free this thread's memory\n"); + PL_debug &= ~ DEBUG_m_FLAG; + } + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ + char * next = (char *)(aTHXx->Imemory_debug_header.next); + Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; + safesysfree(ptr); + } + PL_debug = old_debug; + } } #endif @@ -1564,13 +1564,13 @@ perl_free(pTHXx) # if defined(PERL_IMPLICIT_SYS) { # ifdef NETWARE - void *host = nw_internal_host; - PerlMem_free(aTHXx); - nw_delete_internal_host(host); + void *host = nw_internal_host; + PerlMem_free(aTHXx); + nw_delete_internal_host(host); # else - void *host = w32_internal_host; - PerlMem_free(aTHXx); - win32_delete_internal_host(host); + void *host = w32_internal_host; + PerlMem_free(aTHXx); + win32_delete_internal_host(host); # endif } # else @@ -1599,7 +1599,7 @@ perl_fini(void) { if ( PL_curinterp && !PL_veto_cleanup) - FREE_THREAD_KEY; + FREE_THREAD_KEY; } #endif /* WIN32 */ @@ -1675,10 +1675,10 @@ bug is due to be fixed in Perl 5.30. */ #define SET_CURSTASH(newstash) \ - if (PL_curstash != newstash) { \ - SvREFCNT_dec(PL_curstash); \ - PL_curstash = (HV *)SvREFCNT_inc(newstash); \ - } + if (PL_curstash != newstash) { \ + SvREFCNT_dec(PL_curstash); \ + PL_curstash = (HV *)SvREFCNT_inc(newstash); \ + } int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) @@ -1720,124 +1720,124 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #endif { - int i; - assert(argc >= 0); - for(i = 0; i != argc; i++) - assert(argv[i]); - assert(!argv[argc]); + int i; + assert(argc >= 0); + for(i = 0; i != argc; i++) + assert(argv[i]); + assert(!argv[argc]); } PL_origargc = argc; PL_origargv = argv; if (PL_origalen != 0) { - PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ + PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ } else { - /* Set PL_origalen be the sum of the contiguous argv[] - * elements plus the size of the env in case that it is - * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() - * as the maximum modifiable length of $0. In the worst case - * the area we are able to modify is limited to the size of - * the original argv[0]. (See below for 'contiguous', though.) - * --jhi */ - const char *s = NULL; - const UV mask = ~(UV)(PTRSIZE-1); + /* Set PL_origalen be the sum of the contiguous argv[] + * elements plus the size of the env in case that it is + * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() + * as the maximum modifiable length of $0. In the worst case + * the area we are able to modify is limited to the size of + * the original argv[0]. (See below for 'contiguous', though.) + * --jhi */ + const char *s = NULL; + const UV mask = ~(UV)(PTRSIZE-1); /* Do the mask check only if the args seem like aligned. */ - const UV aligned = - (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); - - /* See if all the arguments are contiguous in memory. Note - * that 'contiguous' is a loose term because some platforms - * align the argv[] and the envp[]. If the arguments look - * like non-aligned, assume that they are 'strictly' or - * 'traditionally' contiguous. If the arguments look like - * aligned, we just check that they are within aligned - * PTRSIZE bytes. As long as no system has something bizarre - * like the argv[] interleaved with some other data, we are - * fine. (Did I just evoke Murphy's Law?) --jhi */ - if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { + const UV aligned = + (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); + + /* See if all the arguments are contiguous in memory. Note + * that 'contiguous' is a loose term because some platforms + * align the argv[] and the envp[]. If the arguments look + * like non-aligned, assume that they are 'strictly' or + * 'traditionally' contiguous. If the arguments look like + * aligned, we just check that they are within aligned + * PTRSIZE bytes. As long as no system has something bizarre + * like the argv[] interleaved with some other data, we are + * fine. (Did I just evoke Murphy's Law?) --jhi */ + if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { int i; - while (*s) s++; - for (i = 1; i < PL_origargc; i++) { - if ((PL_origargv[i] == s + 1 + while (*s) s++; + for (i = 1; i < PL_origargc; i++) { + if ((PL_origargv[i] == s + 1 #ifdef OS2 - || PL_origargv[i] == s + 2 + || PL_origargv[i] == s + 2 #endif - ) - || - (aligned && - (PL_origargv[i] > s && - PL_origargv[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origargv[i]; - while (*s) s++; - } - else - break; - } - } + ) + || + (aligned && + (PL_origargv[i] > s && + PL_origargv[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origargv[i]; + while (*s) s++; + } + else + break; + } + } #ifndef PERL_USE_SAFE_PUTENV - /* Can we grab env area too to be used as the area for $0? */ - if (s && PL_origenviron && !PL_use_safe_putenv) { - if ((PL_origenviron[0] == s + 1) - || - (aligned && - (PL_origenviron[0] > s && - PL_origenviron[0] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { + /* Can we grab env area too to be used as the area for $0? */ + if (s && PL_origenviron && !PL_use_safe_putenv) { + if ((PL_origenviron[0] == s + 1) + || + (aligned && + (PL_origenviron[0] > s && + PL_origenviron[0] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { int i; #ifndef OS2 /* ENVIRON is read by the kernel too. */ - s = PL_origenviron[0]; - while (*s) s++; -#endif - my_setenv("NoNe SuCh", NULL); - /* Force copy of environment. */ - for (i = 1; PL_origenviron[i]; i++) { - if (PL_origenviron[i] == s + 1 - || - (aligned && - (PL_origenviron[i] > s && - PL_origenviron[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origenviron[i]; - while (*s) s++; - } - else - break; - } - } - } + s = PL_origenviron[0]; + while (*s) s++; +#endif + my_setenv("NoNe SuCh", NULL); + /* Force copy of environment. */ + for (i = 1; PL_origenviron[i]; i++) { + if (PL_origenviron[i] == s + 1 + || + (aligned && + (PL_origenviron[i] > s && + PL_origenviron[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origenviron[i]; + while (*s) s++; + } + else + break; + } + } + } #endif /* !defined(PERL_USE_SAFE_PUTENV) */ - PL_origalen = s ? s - PL_origargv[0] + 1 : 0; + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } if (PL_do_undump) { - /* Come here if running an undumped a.out. */ + /* Come here if running an undumped a.out. */ - PL_origfilename = savepv(argv[0]); - PL_do_undump = FALSE; - cxstack_ix = -1; /* start label stack again */ - init_ids(); - assert (!TAINT_get); - TAINT; - set_caret_X(); - TAINT_NOT; - init_postdump_symbols(argc,argv,env); - return 0; + PL_origfilename = savepv(argv[0]); + PL_do_undump = FALSE; + cxstack_ix = -1; /* start label stack again */ + init_ids(); + assert (!TAINT_get); + TAINT; + set_caret_X(); + TAINT_NOT; + init_postdump_symbols(argc,argv,env); + return 0; } if (PL_main_root) { - op_free(PL_main_root); - PL_main_root = NULL; + op_free(PL_main_root); + PL_main_root = NULL; } PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); @@ -1850,47 +1850,47 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) JMPENV_PUSH(ret); switch (ret) { case 0: - parse_body(env,xsinit); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = 0; - break; + parse_body(env,xsinit); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = 0; + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = STATUS_EXIT; - if (ret == 0) { - /* - * At this point we should do - * ret = 0x100; - * to avoid [perl #2754], but that bugfix has been postponed - * because of the Module::Install breakage it causes - * [perl #132577]. - */ - } - break; + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = STATUS_EXIT; + if (ret == 0) { + /* + * At this point we should do + * ret = 0x100; + * to avoid [perl #2754], but that bugfix has been postponed + * because of the Module::Install breakage it causes + * [perl #132577]. + */ + } + break; case 3: - PerlIO_printf(Perl_error_log, "panic: top_env\n"); - ret = 1; - break; + PerlIO_printf(Perl_error_log, "panic: top_env\n"); + ret = 1; + break; } JMPENV_POP; return ret; @@ -1914,123 +1914,123 @@ S_Internals_V(pTHX_ CV *cv) int i; static const char non_bincompat_options[] = # ifdef DEBUGGING - " DEBUGGING" + " DEBUGGING" # endif # ifdef NO_MATHOMS - " NO_MATHOMS" + " NO_MATHOMS" # endif # ifdef NO_HASH_SEED - " NO_HASH_SEED" + " NO_HASH_SEED" # endif # ifdef NO_TAINT_SUPPORT - " NO_TAINT_SUPPORT" + " NO_TAINT_SUPPORT" # endif # ifdef PERL_BOOL_AS_CHAR - " PERL_BOOL_AS_CHAR" + " PERL_BOOL_AS_CHAR" # endif # ifdef PERL_COPY_ON_WRITE - " PERL_COPY_ON_WRITE" + " PERL_COPY_ON_WRITE" # endif # ifdef PERL_DISABLE_PMC - " PERL_DISABLE_PMC" + " PERL_DISABLE_PMC" # endif # ifdef PERL_DONT_CREATE_GVSV - " PERL_DONT_CREATE_GVSV" + " PERL_DONT_CREATE_GVSV" # endif # ifdef PERL_EXTERNAL_GLOB - " PERL_EXTERNAL_GLOB" + " PERL_EXTERNAL_GLOB" # endif # ifdef PERL_HASH_FUNC_SIPHASH - " PERL_HASH_FUNC_SIPHASH" + " PERL_HASH_FUNC_SIPHASH" # endif # ifdef PERL_HASH_FUNC_SDBM - " PERL_HASH_FUNC_SDBM" + " PERL_HASH_FUNC_SDBM" # endif # ifdef PERL_HASH_FUNC_DJB2 - " PERL_HASH_FUNC_DJB2" + " PERL_HASH_FUNC_DJB2" # endif # ifdef PERL_HASH_FUNC_SUPERFAST - " PERL_HASH_FUNC_SUPERFAST" + " PERL_HASH_FUNC_SUPERFAST" # endif # ifdef PERL_HASH_FUNC_MURMUR3 - " PERL_HASH_FUNC_MURMUR3" + " PERL_HASH_FUNC_MURMUR3" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME - " PERL_HASH_FUNC_ONE_AT_A_TIME" + " PERL_HASH_FUNC_ONE_AT_A_TIME" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD - " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" + " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD - " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" + " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" # endif # ifdef PERL_IS_MINIPERL - " PERL_IS_MINIPERL" + " PERL_IS_MINIPERL" # endif # ifdef PERL_MALLOC_WRAP - " PERL_MALLOC_WRAP" + " PERL_MALLOC_WRAP" # endif # ifdef PERL_MEM_LOG - " PERL_MEM_LOG" + " PERL_MEM_LOG" # endif # ifdef PERL_MEM_LOG_NOIMPL - " PERL_MEM_LOG_NOIMPL" + " PERL_MEM_LOG_NOIMPL" # endif # ifdef PERL_OP_PARENT - " PERL_OP_PARENT" + " PERL_OP_PARENT" # endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC - " PERL_PERTURB_KEYS_DETERMINISTIC" + " PERL_PERTURB_KEYS_DETERMINISTIC" # endif # ifdef PERL_PERTURB_KEYS_DISABLED - " PERL_PERTURB_KEYS_DISABLED" + " PERL_PERTURB_KEYS_DISABLED" # endif # ifdef PERL_PERTURB_KEYS_RANDOM - " PERL_PERTURB_KEYS_RANDOM" + " PERL_PERTURB_KEYS_RANDOM" # endif # ifdef PERL_PRESERVE_IVUV - " PERL_PRESERVE_IVUV" + " PERL_PRESERVE_IVUV" # endif # ifdef PERL_RELOCATABLE_INCPUSH - " PERL_RELOCATABLE_INCPUSH" + " PERL_RELOCATABLE_INCPUSH" # endif # ifdef PERL_USE_DEVEL - " PERL_USE_DEVEL" + " PERL_USE_DEVEL" # endif # ifdef PERL_USE_SAFE_PUTENV - " PERL_USE_SAFE_PUTENV" + " PERL_USE_SAFE_PUTENV" # endif # ifdef SILENT_NO_TAINT_SUPPORT - " SILENT_NO_TAINT_SUPPORT" + " SILENT_NO_TAINT_SUPPORT" # endif # ifdef UNLINK_ALL_VERSIONS - " UNLINK_ALL_VERSIONS" + " UNLINK_ALL_VERSIONS" # endif # ifdef USE_ATTRIBUTES_FOR_PERLIO - " USE_ATTRIBUTES_FOR_PERLIO" + " USE_ATTRIBUTES_FOR_PERLIO" # endif # ifdef USE_FAST_STDIO - " USE_FAST_STDIO" + " USE_FAST_STDIO" # endif # ifdef USE_LOCALE - " USE_LOCALE" + " USE_LOCALE" # endif # ifdef USE_LOCALE_CTYPE - " USE_LOCALE_CTYPE" + " USE_LOCALE_CTYPE" # endif # ifdef WIN32_NO_REGISTRY - " USE_NO_REGISTRY" + " USE_NO_REGISTRY" # endif # ifdef USE_PERL_ATOF - " USE_PERL_ATOF" + " USE_PERL_ATOF" # endif # ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" + " USE_SITECUSTOMIZE" # endif # ifdef USE_THREAD_SAFE_LOCALE - " USE_THREAD_SAFE_LOCALE" + " USE_THREAD_SAFE_LOCALE" # endif - ; + ; PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); @@ -2038,7 +2038,7 @@ S_Internals_V(pTHX_ CV *cv) PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, - sizeof(non_bincompat_options) - 1, SVs_TEMP)); + sizeof(non_bincompat_options) - 1, SVs_TEMP)); #ifndef PERL_BUILD_DATE # ifdef __DATE__ @@ -2052,15 +2052,15 @@ S_Internals_V(pTHX_ CV *cv) #ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), - SVs_TEMP)); + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), + SVs_TEMP)); #else PUSHs(&PL_sv_undef); #endif for (i = 1; i <= local_patch_count; i++) { - /* This will be an undef, if PL_localpatches[i] is NULL. */ - PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); + /* This will be an undef, if PL_localpatches[i] is NULL. */ + PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); } XSRETURN(entries); @@ -2099,231 +2099,231 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) init_main_stash(); { - const char *s; + const char *s; for (argc--,argv++; argc > 0; argc--,argv++) { - if (argv[0][0] != '-' || !argv[0][1]) - break; - s = argv[0]+1; + if (argv[0][0] != '-' || !argv[0][1]) + break; + s = argv[0]+1; reswitch: - switch ((c = *s)) { - case 'C': + switch ((c = *s)) { + case 'C': #ifndef PERL_STRICT_CR - case '\r': -#endif - case ' ': - case '0': - case 'F': - case 'a': - case 'c': - case 'd': - case 'D': - case 'h': - case 'i': - case 'l': - case 'M': - case 'm': - case 'n': - case 'p': - case 's': - case 'u': - case 'U': - case 'v': - case 'W': - case 'X': - case 'w': - if ((s = moreswitches(s))) - goto reswitch; - break; - - case 't': + case '\r': +#endif + case ' ': + case '0': + case 'F': + case 'a': + case 'c': + case 'd': + case 'D': + case 'h': + case 'i': + case 'l': + case 'M': + case 'm': + case 'n': + case 'p': + case 's': + case 'u': + case 'U': + case 'v': + case 'W': + case 'X': + case 'w': + if ((s = moreswitches(s))) + goto reswitch; + break; + + case 't': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('t'); - if( !TAINTING_get ) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - s++; - goto reswitch; - case 'T': + CHECK_MALLOC_TOO_LATE_FOR('t'); + if( !TAINTING_get ) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + s++; + goto reswitch; + case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); - TAINT_WARN_set(FALSE); -#endif - s++; - goto reswitch; - - case 'E': - PL_minus_E = TRUE; - /* FALLTHROUGH */ - case 'e': - forbid_setid('e', FALSE); + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif + s++; + goto reswitch; + + case 'E': + PL_minus_E = TRUE; + /* FALLTHROUGH */ + case 'e': + forbid_setid('e', FALSE); minus_e = TRUE; - if (!PL_e_script) { - PL_e_script = newSVpvs(""); - add_read_e_script = TRUE; - } - if (*++s) - sv_catpv(PL_e_script, s); - else if (argv[1]) { - sv_catpv(PL_e_script, argv[1]); - argc--,argv++; - } - else - Perl_croak(aTHX_ "No code specified for -%c", c); - sv_catpvs(PL_e_script, "\n"); - break; - - case 'f': + if (!PL_e_script) { + PL_e_script = newSVpvs(""); + add_read_e_script = TRUE; + } + if (*++s) + sv_catpv(PL_e_script, s); + else if (argv[1]) { + sv_catpv(PL_e_script, argv[1]); + argc--,argv++; + } + else + Perl_croak(aTHX_ "No code specified for -%c", c); + sv_catpvs(PL_e_script, "\n"); + break; + + case 'f': #ifdef USE_SITECUSTOMIZE - minus_f = TRUE; -#endif - s++; - goto reswitch; - - case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid('I', FALSE); - if (!*++s && (s=argv[1]) != NULL) { - argc--,argv++; - } - if (s && *s) { - STRLEN len = strlen(s); - incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - break; - case 'S': - forbid_setid('S', FALSE); - dosearch = TRUE; - s++; - goto reswitch; - case 'V': - { - SV *opts_prog; - - if (*++s != ':') { - opts_prog = newSVpvs("use Config; Config::_V()"); - } - else { - ++s; - opts_prog = Perl_newSVpvf(aTHX_ - "use Config; Config::config_vars(qw%c%s%c)", - 0, s, 0); - s += strlen(s); - } - Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); - /* don't look for script or read stdin */ - scriptname = BIT_BUCKET; - goto reswitch; - } - case 'x': - doextract = TRUE; - s++; - if (*s) - cddir = s; - break; - case 0: - break; - case '-': - if (!*++s || isSPACE(*s)) { - argc--,argv++; - goto switch_end; - } - /* catch use of gnu style long options. - Both of these exit immediately. */ - if (strEQ(s, "version")) - minus_v(); - if (strEQ(s, "help")) - usage(); - s--; - /* FALLTHROUGH */ - default: - Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); - } + minus_f = TRUE; +#endif + s++; + goto reswitch; + + case 'I': /* -I handled both here and in moreswitches() */ + forbid_setid('I', FALSE); + if (!*++s && (s=argv[1]) != NULL) { + argc--,argv++; + } + if (s && *s) { + STRLEN len = strlen(s); + incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + break; + case 'S': + forbid_setid('S', FALSE); + dosearch = TRUE; + s++; + goto reswitch; + case 'V': + { + SV *opts_prog; + + if (*++s != ':') { + opts_prog = newSVpvs("use Config; Config::_V()"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "use Config; Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); + /* don't look for script or read stdin */ + scriptname = BIT_BUCKET; + goto reswitch; + } + case 'x': + doextract = TRUE; + s++; + if (*s) + cddir = s; + break; + case 0: + break; + case '-': + if (!*++s || isSPACE(*s)) { + argc--,argv++; + goto switch_end; + } + /* catch use of gnu style long options. + Both of these exit immediately. */ + if (strEQ(s, "version")) + minus_v(); + if (strEQ(s, "help")) + usage(); + s--; + /* FALLTHROUGH */ + default: + Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); + } } } switch_end: { - char *s; + char *s; if ( #ifndef SECURE_INTERNAL_GETENV !TAINTING_get && #endif - (s = PerlEnv_getenv("PERL5OPT"))) + (s = PerlEnv_getenv("PERL5OPT"))) { - while (isSPACE(*s)) - s++; - if (*s == '-' && *(s+1) == 'T') { + while (isSPACE(*s)) + s++; + if (*s == '-' && *(s+1) == 'T') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); TAINT_WARN_set(FALSE); #endif - } - else { - char *popt_copy = NULL; - while (s && *s) { - const char *d; - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; - } - d = s; - if (!*s) - break; - if (!memCHRs("CDIMUdmtwW", *s)) - Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - while (++s && *s) { - if (isSPACE(*s)) { - if (!popt_copy) { - popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); - s = popt_copy + (s - d); - d = popt_copy; - } - *s++ = '\0'; - break; - } - } - if (*d == 't') { + } + else { + char *popt_copy = NULL; + while (s && *s) { + const char *d; + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + d = s; + if (!*s) + break; + if (!memCHRs("CDIMUdmtwW", *s)) + Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); + while (++s && *s) { + if (isSPACE(*s)) { + if (!popt_copy) { + popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); + s = popt_copy + (s - d); + d = popt_copy; + } + *s++ = '\0'; + break; + } + } + if (*d == 't') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - if( !TAINTING_get) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - } else { - moreswitches(d); - } - } - } + if( !TAINTING_get) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + } else { + moreswitches(d); + } + } + } } } @@ -2351,101 +2351,101 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(USE_SITECUSTOMIZE) if (!minus_f) { - /* The games with local $! are to avoid setting errno if there is no - sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", - ie a q() operator with a NUL byte as a the delimiter. This avoids - problems with pathnames containing (say) ' */ + /* The games with local $! are to avoid setting errno if there is no + sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", + ie a q() operator with a NUL byte as a the delimiter. This avoids + problems with pathnames containing (say) ' */ # ifdef PERL_IS_MINIPERL - AV *const inc = GvAV(PL_incgv); - SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; + AV *const inc = GvAV(PL_incgv); + SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; - if (inc0) { + if (inc0) { /* if lib/buildcustomize.pl exists, it should not fail. If it does, it should be reported immediately as a build failure. */ - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " - "do {local $!; -f $f }" - " and do $f || die $@ || qq '$f: $!' }", + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " + "do {local $!; -f $f }" + " and do $f || die $@ || qq '$f: $!' }", 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); - } + } # else - /* SITELIB_EXP is a function call on Win32. */ - const char *const raw_sitelib = SITELIB_EXP; - if (raw_sitelib) { - /* process .../.. if PERL_RELOCATABLE_INC is defined */ - SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), - INCPUSH_CAN_RELOCATE); - const char *const sitelib = SvPVX(sitelib_sv); - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", - 0, SVfARG(sitelib), 0, - 0, SVfARG(sitelib), 0)); - assert (SvREFCNT(sitelib_sv) == 1); - SvREFCNT_dec(sitelib_sv); - } + /* SITELIB_EXP is a function call on Win32. */ + const char *const raw_sitelib = SITELIB_EXP; + if (raw_sitelib) { + /* process .../.. if PERL_RELOCATABLE_INC is defined */ + SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), + INCPUSH_CAN_RELOCATE); + const char *const sitelib = SvPVX(sitelib_sv); + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", + 0, SVfARG(sitelib), 0, + 0, SVfARG(sitelib), 0)); + assert (SvREFCNT(sitelib_sv) == 1); + SvREFCNT_dec(sitelib_sv); + } # endif } #endif if (!scriptname) - scriptname = argv[0]; + scriptname = argv[0]; if (PL_e_script) { - argc++,argv--; - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ + argc++,argv--; + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } else if (scriptname == NULL) { #ifdef MSDOS - if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("h"); + if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) + moreswitches("h"); #endif - scriptname = "-"; + scriptname = "-"; } assert (!TAINT_get); init_perllib(); { - bool suidscript = FALSE; + bool suidscript = FALSE; - rsfp = open_script(scriptname, dosearch, &suidscript); - if (!rsfp) { - rsfp = PerlIO_stdin(); - lex_start_flags = LEX_DONT_CLOSE_RSFP; - } + rsfp = open_script(scriptname, dosearch, &suidscript); + if (!rsfp) { + rsfp = PerlIO_stdin(); + lex_start_flags = LEX_DONT_CLOSE_RSFP; + } - validate_suid(rsfp); + validate_suid(rsfp); #ifndef PERL_MICRO # if defined(SIGCHLD) || defined(SIGCLD) - { + { # ifndef SIGCHLD # define SIGCHLD SIGCLD # endif - Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == (Sighandler_t) SIG_IGN) { - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); - (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); - } - } + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == (Sighandler_t) SIG_IGN) { + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } # endif #endif - if (doextract) { + if (doextract) { - /* This will croak if suidscript is true, as -x cannot be used with - setuid scripts. */ - forbid_setid('x', suidscript); - /* Hence you can't get here if suidscript is true */ + /* This will croak if suidscript is true, as -x cannot be used with + setuid scripts. */ + forbid_setid('x', suidscript); + /* Hence you can't get here if suidscript is true */ - linestr_sv = newSV_type(SVt_PV); - lex_start_flags |= LEX_START_COPIED; - find_beginning(linestr_sv, rsfp); - if (cddir && PerlDir_chdir( (char *)cddir ) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",cddir); - } + linestr_sv = newSV_type(SVt_PV); + lex_start_flags |= LEX_START_COPIED; + find_beginning(linestr_sv, rsfp); + if (cddir && PerlDir_chdir( (char *)cddir ) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + } } PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); @@ -2461,7 +2461,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) newXS("Internals::V", S_Internals_V, __FILE__); if (xsinit) - (*xsinit)(aTHX); /* in case linked C routines want magical variables */ + (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); @@ -2481,7 +2481,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* more than once (ENV isn't cleared first, for example) */ /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!PL_do_undump) - init_postdump_symbols(argc,argv,env); + init_postdump_symbols(argc,argv,env); /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, * or explicitly in some platforms. @@ -2490,54 +2490,54 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) * look like the user wants to use UTF-8. */ # ifndef PERL_IS_MINIPERL if (PL_unicode) { - /* Requires init_predump_symbols(). */ - if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { - IO* io; - PerlIO* fp; - SV* sv; - - /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR - * and the default open disciplines. */ - if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && - PL_stdingv && (io = GvIO(PL_stdingv)) && - (fp = IoIFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && - PL_defoutgv && (io = GvIO(PL_defoutgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && - PL_stderrgv && (io = GvIO(PL_stderrgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && - (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, - SVt_PV)))) { - U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; - U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; - if (in) { - if (out) - sv_setpvs(sv, ":utf8\0:utf8"); - else - sv_setpvs(sv, ":utf8\0"); - } - else if (out) - sv_setpvs(sv, "\0:utf8"); - SvSETMAGIC(sv); - } - } + /* Requires init_predump_symbols(). */ + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + IO* io; + PerlIO* fp; + SV* sv; + + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * and the default open disciplines. */ + if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && + PL_stdingv && (io = GvIO(PL_stdingv)) && + (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && + PL_defoutgv && (io = GvIO(PL_defoutgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && + PL_stderrgv && (io = GvIO(PL_stderrgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && + (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, + SVt_PV)))) { + U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; + U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; + if (in) { + if (out) + sv_setpvs(sv, ":utf8\0:utf8"); + else + sv_setpvs(sv, ":utf8\0"); + } + else if (out) + sv_setpvs(sv, "\0:utf8"); + SvSETMAGIC(sv); + } + } } #endif { - const char *s; + const char *s; if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { - if (strEQ(s, "unsafe")) - PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; - else if (strEQ(s, "safe")) - PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; - else - Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); + if (strEQ(s, "unsafe")) + PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; + else if (strEQ(s, "safe")) + PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; + else + Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } } @@ -2548,7 +2548,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_subname = newSVpvs("main"); if (add_read_e_script) - filter_add(read_e_script, NULL); + filter_add(read_e_script, NULL); /* now parse the script */ if (minus_e == FALSE) @@ -2561,17 +2561,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) CopLINE_set(PL_curcop, 0); SET_CURSTASH(PL_defstash); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } if (PL_do_undump) - my_unexec(); + my_unexec(); if (isWARN_ONCE) { - SAVECOPFILE(PL_curcop); - SAVECOPLINE(PL_curcop); - gv_check(PL_defstash); + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); + gv_check(PL_defstash); } LEAVE; @@ -2579,7 +2579,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MYMALLOC { - const char *s; + const char *s; UV uv; s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) @@ -2659,37 +2659,37 @@ perl_run(pTHXx) JMPENV_PUSH(ret); switch (ret) { case 1: - cxstack_ix = -1; /* start context stack again */ - goto redo_body; + cxstack_ix = -1; /* start context stack again */ + goto redo_body; case 0: /* normal completion */ redo_body: - run_body(oldscope); - /* FALLTHROUGH */ + run_body(oldscope); + /* FALLTHROUGH */ case 2: /* my_exit() */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && - PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); - call_list(oldscope, PL_endav); - } + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && + PL_endav && !PL_minus_c) { + PERL_SET_PHASE(PERL_PHASE_END); + call_list(oldscope, PL_endav); + } #ifdef MYMALLOC - if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) - dump_mstats("after execution: "); + if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) + dump_mstats("after execution: "); #endif - ret = STATUS_EXIT; - break; + ret = STATUS_EXIT; + break; case 3: - if (PL_restartop) { - POPSTACK_TO(PL_mainstack); - goto redo_body; - } - PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); - FREETMPS; - ret = 1; - break; + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + goto redo_body; + } + PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); + FREETMPS; + ret = 1; + break; } JMPENV_POP; @@ -2705,25 +2705,25 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { #ifdef DEBUGGING - if (DEBUG_x_TEST || DEBUG_B_TEST) - dump_all_perl(!DEBUG_B_TEST); - if (!DEBUG_q_TEST) - PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); + if (!DEBUG_q_TEST) + PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #endif - if (PL_minus_c) { - PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); - my_exit(0); - } - if (PERLDB_SINGLE && PL_DBsingle) + if (PL_minus_c) { + PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); + my_exit(0); + } + if (PERLDB_SINGLE && PL_DBsingle) PL_DBsingle_iv = 1; - if (PL_initav) { - PERL_SET_PHASE(PERL_PHASE_INIT); - call_list(oldscope, PL_initav); - } + if (PL_initav) { + PERL_SET_PHASE(PERL_PHASE_INIT); + call_list(oldscope, PL_initav); + } #ifdef PERL_DEBUG_READONLY_OPS - if (PL_main_root && PL_main_root->op_slabbed) - Slab_to_ro(OpSLAB(PL_main_root)); + if (PL_main_root && PL_main_root->op_slabbed) + Slab_to_ro(OpSLAB(PL_main_root)); #endif } @@ -2732,15 +2732,15 @@ S_run_body(pTHX_ I32 oldscope) PERL_SET_PHASE(PERL_PHASE_RUN); if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - CALLRUNOPS(aTHX); + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + CALLRUNOPS(aTHX); } else if (PL_main_start) { - CvDEPTH(PL_main_cv) = 1; - PL_op = PL_main_start; - CALLRUNOPS(aTHX); + CvDEPTH(PL_main_cv) = 1; + PL_op = PL_main_start; + CALLRUNOPS(aTHX); } my_exit(0); NOT_REACHED; /* NOTREACHED */ @@ -2768,7 +2768,7 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) gv = gv_fetchpv(name, flags, SVt_PV); if (gv) - return GvSV(gv); + return GvSV(gv); return NULL; } @@ -2796,9 +2796,9 @@ Perl_get_av(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_AV; if (flags) - return GvAVn(gv); + return GvAVn(gv); if (gv) - return GvAV(gv); + return GvAV(gv); return NULL; } @@ -2823,9 +2823,9 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_HV; if (flags) - return GvHVn(gv); + return GvHVn(gv); if (gv) - return GvHV(gv); + return GvHV(gv); return NULL; } @@ -2862,16 +2862,16 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) PERL_ARGS_ASSERT_GET_CVN_FLAGS; if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV) - return (CV*)SvRV((SV *)gv); + return (CV*)SvRV((SV *)gv); /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { - return newSTUB(gv,0); + return newSTUB(gv,0); } if (gv) - return GvCVu(gv); + return GvCVu(gv); return NULL; } @@ -2905,8 +2905,8 @@ Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) - /* See G_* flags in cop.h */ - /* null terminated arg list */ + /* See G_* flags in cop.h */ + /* null terminated arg list */ { dSP; @@ -2931,8 +2931,8 @@ Performs a callback to the specified Perl sub. See L. I32 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { PERL_ARGS_ASSERT_CALL_PV; @@ -2950,8 +2950,8 @@ be on the stack. See L. I32 Perl_call_method(pTHX_ const char *methname, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { STRLEN len; SV* sv; @@ -2994,7 +2994,7 @@ See L. I32 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) - /* See G_* flags in cop.h */ + /* See G_* flags in cop.h */ { LOGOP myop; /* fake syntax tree node */ METHOP method_op; @@ -3008,38 +3008,38 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) PERL_ARGS_ASSERT_CALL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } if (!(flags & G_WANT)) { - /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. - */ - flags |= G_SCALAR; + /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. + */ + flags |= G_SCALAR; } Zero(&myop, 1, LOGOP); if (!(flags & G_NOARGS)) - myop.op_flags |= OPf_STACKED; + myop.op_flags |= OPf_STACKED; myop.op_flags |= OP_GIMME_REVERSE(flags); SAVEOP(); PL_op = (OP*)&myop; if (!(flags & G_METHOD_NAMED)) { - dSP; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; } oldmark = TOPMARK; if (PERLDB_SUB && PL_curstash != PL_debstash - /* Handle first BEGIN of -d. */ - && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) - /* Try harder, since this may have been a sighandler, thus - * curstash may be meaningless. */ - && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) - && !(flags & G_NODEBUG)) - myop.op_private |= OPpENTERSUB_DB; + /* Handle first BEGIN of -d. */ + && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) + /* Try harder, since this may have been a sighandler, thus + * curstash may be meaningless. */ + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) + && !(flags & G_NODEBUG)) + myop.op_private |= OPpENTERSUB_DB; if (flags & (G_METHOD|G_METHOD_NAMED)) { Zero(&method_op, 1, METHOP); @@ -3058,72 +3058,72 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) } if (!(flags & G_EVAL)) { - CATCH_SET(TRUE); - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - CATCH_SET(oldcatch); + CATCH_SET(TRUE); + CALL_BODY_SUB((OP*)&myop); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(oldcatch); } else { I32 old_cxix; - myop.op_other = (OP*)&myop; - (void)POPMARK; + myop.op_other = (OP*)&myop; + (void)POPMARK; old_cxix = cxstack_ix; - create_eval_scope(NULL, flags|G_FAKINGEVAL); - INCMARK; + create_eval_scope(NULL, flags|G_FAKINGEVAL); + INCMARK; - JMPENV_PUSH(ret); + JMPENV_PUSH(ret); - switch (ret) { - case 0: + switch (ret) { + case 0: redo_body: - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) { - CLEAR_ERRSV(); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; - } + CALL_BODY_SUB((OP*)&myop); + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_ARRAY) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; + } /* if we croaked, depending on how we croaked the eval scope * may or may not have already been popped */ - if (cxstack_ix > old_cxix) { + if (cxstack_ix > old_cxix) { assert(cxstack_ix == old_cxix + 1); assert(CxTYPE(CX_CUR()) == CXt_EVAL); - delete_eval_scope(); + delete_eval_scope(); } - JMPENV_POP; + JMPENV_POP; } if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; @@ -3147,7 +3147,7 @@ execute code specified by a string, but not catch any errors. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ + /* See G_* flags in cop.h */ { UNOP myop; /* fake syntax tree node */ volatile I32 oldmark; @@ -3159,30 +3159,30 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_EVAL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); { - dSP; - oldmark = SP - PL_stack_base; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; } if (!(flags & G_NOARGS)) - myop.op_flags = OPf_STACKED; + myop.op_flags = OPf_STACKED; myop.op_type = OP_ENTEREVAL; myop.op_flags |= OP_GIMME_REVERSE(flags); if (flags & G_KEEPERR) - myop.op_flags |= OPf_SPECIAL; + myop.op_flags |= OPf_SPECIAL; if (flags & G_RE_REPARSING) - myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); + myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); /* fail now; otherwise we could fail after the JMPENV_PUSH but * before a cx_pusheval(), which corrupts the stack after a croak */ @@ -3192,56 +3192,56 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - if (PL_op == (OP*)(&myop)) { - PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); - if (!PL_op) - goto fail; /* failed in compilation */ - } - CALLRUNOPS(aTHX); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) { - CLEAR_ERRSV(); - } - break; + if (PL_op == (OP*)(&myop)) { + PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); + if (!PL_op) + goto fail; /* failed in compilation */ + } + CALLRUNOPS(aTHX); + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } fail: if (flags & G_RETHROW) { JMPENV_POP; croak_sv(ERRSV); } - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_ARRAY) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; } JMPENV_POP; if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; @@ -3352,10 +3352,10 @@ NULL PerlIO *out = PerlIO_stdout(); PerlIO_printf(out, - "\nUsage: %s [switches] [--] [programfile] [arguments]\n", - PL_origargv[0]); + "\nUsage: %s [switches] [--] [programfile] [arguments]\n", + PL_origargv[0]); while (*p) - PerlIO_puts(out, *p++); + PerlIO_puts(out, *p++); my_exit(0); } @@ -3403,23 +3403,23 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) PERL_ARGS_ASSERT_GET_DEBUG_OPTS; if (isALPHA(**s)) { - /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; - - for (; isWORDCHAR(**s); (*s)++) { - const char * const d = strchr(debopts,**s); - if (d) - uv |= 1 << (d - debopts); - else if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "invalid option -D%c, use -D'' to see choices\n", **s); - } + /* if adding extra options, remember to update DEBUG_MASK */ + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; + + for (; isWORDCHAR(**s); (*s)++) { + const char * const d = strchr(debopts,**s); + if (d) + uv |= 1 << (d - debopts); + else if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "invalid option -D%c, use -D'' to see choices\n", **s); + } } else if (isDIGIT(**s)) { const char* e = *s + strlen(*s); - if (grok_atoUV(*s, &uv, &e)) + if (grok_atoUV(*s, &uv, &e)) *s = e; - for (; isWORDCHAR(**s); (*s)++) ; + for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { const char *const *p = usage_msgd; @@ -3442,259 +3442,259 @@ Perl_moreswitches(pTHX_ const char *s) switch (*s) { case '0': { - I32 flags = 0; - STRLEN numlen; - - SvREFCNT_dec(PL_rs); - if (s[1] == 'x' && s[2]) { - const char *e = s+=2; - U8 *tmps; - - while (*e) - e++; - numlen = e - s; - flags = PERL_SCAN_SILENT_ILLDIGIT; - rschar = (U32)grok_hex(s, &numlen, &flags, NULL); - if (s + numlen < e) { - rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ - numlen = 0; - s--; - } - PL_rs = newSVpvs(""); - tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); - uvchr_to_utf8(tmps, rschar); - SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); - SvUTF8_on(PL_rs); - } - else { - numlen = 4; - rschar = (U32)grok_oct(s, &numlen, &flags, NULL); - if (rschar & ~((U8)~0)) - PL_rs = &PL_sv_undef; - else if (!rschar && numlen >= 2) - PL_rs = newSVpvs(""); - else { - char ch = (char)rschar; - PL_rs = newSVpvn(&ch, 1); - } - } - sv_setsv(get_sv("/", GV_ADD), PL_rs); - return s + numlen; + I32 flags = 0; + STRLEN numlen; + + SvREFCNT_dec(PL_rs); + if (s[1] == 'x' && s[2]) { + const char *e = s+=2; + U8 *tmps; + + while (*e) + e++; + numlen = e - s; + flags = PERL_SCAN_SILENT_ILLDIGIT; + rschar = (U32)grok_hex(s, &numlen, &flags, NULL); + if (s + numlen < e) { + rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ + numlen = 0; + s--; + } + PL_rs = newSVpvs(""); + tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); + uvchr_to_utf8(tmps, rschar); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); + SvUTF8_on(PL_rs); + } + else { + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + if (rschar & ~((U8)~0)) + PL_rs = &PL_sv_undef; + else if (!rschar && numlen >= 2) + PL_rs = newSVpvs(""); + else { + char ch = (char)rschar; + PL_rs = newSVpvn(&ch, 1); + } + } + sv_setsv(get_sv("/", GV_ADD), PL_rs); + return s + numlen; } case 'C': s++; PL_unicode = parse_unicode_opts( (const char **)&s ); - if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) - PL_utf8cache = -1; - return s; + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; + return s; case 'F': - PL_minus_a = TRUE; - PL_minus_F = TRUE; + PL_minus_a = TRUE; + PL_minus_F = TRUE; PL_minus_n = TRUE; - PL_splitstr = ++s; - while (*s && !isSPACE(*s)) ++s; - PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); - return s; + PL_splitstr = ++s; + while (*s && !isSPACE(*s)) ++s; + PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); + return s; case 'a': - PL_minus_a = TRUE; + PL_minus_a = TRUE; PL_minus_n = TRUE; - s++; - return s; + s++; + return s; case 'c': - PL_minus_c = TRUE; - s++; - return s; + PL_minus_c = TRUE; + s++; + return s; case 'd': - forbid_setid('d', FALSE); - s++; + forbid_setid('d', FALSE); + s++; /* -dt indicates to the debugger that threads will be used */ - if (*s == 't' && !isWORDCHAR(s[1])) { - ++s; - my_setenv("PERL5DB_THREADED", "1"); - } - - /* The following permits -d:Mod to accepts arguments following an = - in the fashion that -MSome::Mod does. */ - if (*s == ':' || *s == '=') { - const char *start; - const char *end; - SV *sv; - - if (*++s == '-') { - ++s; - sv = newSVpvs("no Devel::"); - } else { - sv = newSVpvs("use Devel::"); - } - - start = s; - end = s + strlen(s); - - /* We now allow -d:Module=Foo,Bar and -d:-Module */ - while(isWORDCHAR(*s) || *s==':') ++s; - if (*s != '=') - sv_catpvn(sv, start, end - start); - else { - sv_catpvn(sv, start, s-start); - /* Don't use NUL as q// delimiter here, this string goes in the - * environment. */ - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); - } - s = end; - my_setenv("PERL5DB", SvPV_nolen_const(sv)); - SvREFCNT_dec(sv); - } - if (!PL_perldb) { - PL_perldb = PERLDB_ALL; - init_debugger(); - } - return s; + if (*s == 't' && !isWORDCHAR(s[1])) { + ++s; + my_setenv("PERL5DB_THREADED", "1"); + } + + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + const char *start; + const char *end; + SV *sv; + + if (*++s == '-') { + ++s; + sv = newSVpvs("no Devel::"); + } else { + sv = newSVpvs("use Devel::"); + } + + start = s; + end = s + strlen(s); + + /* We now allow -d:Module=Foo,Bar and -d:-Module */ + while(isWORDCHAR(*s) || *s==':') ++s; + if (*s != '=') + sv_catpvn(sv, start, end - start); + else { + sv_catpvn(sv, start, s-start); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); + } + s = end; + my_setenv("PERL5DB", SvPV_nolen_const(sv)); + SvREFCNT_dec(sv); + } + if (!PL_perldb) { + PL_perldb = PERLDB_ALL; + init_debugger(); + } + return s; case 'D': { #ifdef DEBUGGING - forbid_setid('D', FALSE); - s++; - PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; + forbid_setid('D', FALSE); + s++; + PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); - for (s++; isWORDCHAR(*s); s++) ; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); + for (s++; isWORDCHAR(*s); s++) ; #endif - return s; + return s; NOT_REACHED; /* NOTREACHED */ } case 'h': - usage(); + usage(); NOT_REACHED; /* NOTREACHED */ case 'i': - Safefree(PL_inplace); - { - const char * const start = ++s; - while (*s && !isSPACE(*s)) - ++s; - - PL_inplace = savepvn(start, s - start); - } - return s; + Safefree(PL_inplace); + { + const char * const start = ++s; + while (*s && !isSPACE(*s)) + ++s; + + PL_inplace = savepvn(start, s - start); + } + return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid('I', FALSE); - ++s; - while (*s && isSPACE(*s)) - ++s; - if (*s) { - const char *e, *p; - p = s; - /* ignore trailing spaces (possibly followed by other switches) */ - do { - for (e = p; *e && !isSPACE(*e); e++) ; - p = e; - while (isSPACE(*p)) - p++; - } while (*p && *p != '-'); - incpush(s, e-s, - INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); - s = p; - if (*s == '-') - s++; - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - return s; + forbid_setid('I', FALSE); + ++s; + while (*s && isSPACE(*s)) + ++s; + if (*s) { + const char *e, *p; + p = s; + /* ignore trailing spaces (possibly followed by other switches) */ + do { + for (e = p; *e && !isSPACE(*e); e++) ; + p = e; + while (isSPACE(*p)) + p++; + } while (*p && *p != '-'); + incpush(s, e-s, + INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); + s = p; + if (*s == '-') + s++; + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + return s; case 'l': - PL_minus_l = TRUE; - s++; - if (PL_ors_sv) { - SvREFCNT_dec(PL_ors_sv); - PL_ors_sv = NULL; - } - if (isDIGIT(*s)) { + PL_minus_l = TRUE; + s++; + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = NULL; + } + if (isDIGIT(*s)) { I32 flags = 0; - STRLEN numlen; - PL_ors_sv = newSVpvs("\n"); - numlen = 3 + (*s == '0'); - *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); - s += numlen; - } - else { - if (RsPARA(PL_rs)) { - PL_ors_sv = newSVpvs("\n\n"); - } - else { - PL_ors_sv = newSVsv(PL_rs); - } - } - return s; + STRLEN numlen; + PL_ors_sv = newSVpvs("\n"); + numlen = 3 + (*s == '0'); + *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); + s += numlen; + } + else { + if (RsPARA(PL_rs)) { + PL_ors_sv = newSVpvs("\n\n"); + } + else { + PL_ors_sv = newSVsv(PL_rs); + } + } + return s; case 'M': - forbid_setid('M', FALSE); /* XXX ? */ - /* FALLTHROUGH */ + forbid_setid('M', FALSE); /* XXX ? */ + /* FALLTHROUGH */ case 'm': - forbid_setid('m', FALSE); /* XXX ? */ - if (*++s) { - const char *start; - const char *end; - SV *sv; - const char *use = "use "; - bool colon = FALSE; - /* -M-foo == 'no foo' */ - /* Leading space on " no " is deliberate, to make both - possibilities the same length. */ - if (*s == '-') { use = " no "; ++s; } - sv = newSVpvn(use,4); - start = s; - /* We allow -M'Module qw(Foo Bar)' */ - while(isWORDCHAR(*s) || *s==':') { - if( *s++ == ':' ) { - if( *s == ':' ) - s++; - else - colon = TRUE; - } - } - if (s == start) - Perl_croak(aTHX_ "Module name required with -%c option", - option); - if (colon) - Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " - "contains single ':'", - (int)(s - start), start, option); - end = s + strlen(s); - if (*s != '=') { - sv_catpvn(sv, start, end - start); - if (option == 'm') { - if (*s != '\0') - Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); - sv_catpvs( sv, " ()"); - } - } else { - sv_catpvn(sv, start, s-start); - /* Use NUL as q''-delimiter. */ - sv_catpvs(sv, " split(/,/,q\0"); - ++s; - sv_catpvn(sv, s, end - s); - sv_catpvs(sv, "\0)"); - } - s = end; - Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); - } - else - Perl_croak(aTHX_ "Missing argument to -%c", option); - return s; + forbid_setid('m', FALSE); /* XXX ? */ + if (*++s) { + const char *start; + const char *end; + SV *sv; + const char *use = "use "; + bool colon = FALSE; + /* -M-foo == 'no foo' */ + /* Leading space on " no " is deliberate, to make both + possibilities the same length. */ + if (*s == '-') { use = " no "; ++s; } + sv = newSVpvn(use,4); + start = s; + /* We allow -M'Module qw(Foo Bar)' */ + while(isWORDCHAR(*s) || *s==':') { + if( *s++ == ':' ) { + if( *s == ':' ) + s++; + else + colon = TRUE; + } + } + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + option); + if (colon) + Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " + "contains single ':'", + (int)(s - start), start, option); + end = s + strlen(s); + if (*s != '=') { + sv_catpvn(sv, start, end - start); + if (option == 'm') { + if (*s != '\0') + Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); + sv_catpvs( sv, " ()"); + } + } else { + sv_catpvn(sv, start, s-start); + /* Use NUL as q''-delimiter. */ + sv_catpvs(sv, " split(/,/,q\0"); + ++s; + sv_catpvn(sv, s, end - s); + sv_catpvs(sv, "\0)"); + } + s = end; + Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); + } + else + Perl_croak(aTHX_ "Missing argument to -%c", option); + return s; case 'n': - PL_minus_n = TRUE; - s++; - return s; + PL_minus_n = TRUE; + s++; + return s; case 'p': - PL_minus_p = TRUE; - s++; - return s; + PL_minus_p = TRUE; + s++; + return s; case 's': - forbid_setid('s', FALSE); - PL_doswitches = TRUE; - s++; - return s; + forbid_setid('s', FALSE); + PL_doswitches = TRUE; + s++; + return s; case 't': case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) @@ -3704,43 +3704,43 @@ Perl_moreswitches(pTHX_ const char *s) "Cowardly refusing to run with -t or -T flags"); #else if (!TAINTING_get) - TOO_LATE_FOR(*s); + TOO_LATE_FOR(*s); #endif s++; - return s; + return s; case 'u': - PL_do_undump = TRUE; - s++; - return s; + PL_do_undump = TRUE; + s++; + return s; case 'U': - PL_unsafe = TRUE; - s++; - return s; + PL_unsafe = TRUE; + s++; + return s; case 'v': - minus_v(); + minus_v(); case 'w': - if (! (PL_dowarn & G_WARN_ALL_MASK)) { - PL_dowarn |= G_WARN_ON; - } - s++; - return s; + if (! (PL_dowarn & G_WARN_ALL_MASK)) { + PL_dowarn |= G_WARN_ON; + } + s++; + return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); - s++; - return s; + s++; + return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; + PL_dowarn = G_WARN_ALL_OFF; free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); - s++; - return s; + s++; + return s; case '*': case ' ': while( *s == ' ' ) ++s; - if (s[0] == '-') /* Additional switches on #! line. */ - return s+1; - break; + if (s[0] == '-') /* Additional switches on #! line. */ + return s+1; + break; case '-': case 0: #if defined(WIN32) || !defined(PERL_STRICT_CR) @@ -3748,21 +3748,21 @@ Perl_moreswitches(pTHX_ const char *s) #endif case '\n': case '\t': - break; + break; #ifdef ALTERNATE_SHEBANG case 'S': /* OS/2 needs -S on "extproc" line. */ - break; + break; #endif case 'e': case 'f': case 'x': case 'E': #ifndef ALTERNATE_SHEBANG case 'S': #endif case 'V': - Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); + Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); default: - Perl_croak(aTHX_ - "Unrecognized switch: -%.1s (-h will show valid options)",s - ); + Perl_croak(aTHX_ + "Unrecognized switch: -%.1s (-h will show valid options)",s + ); } return NULL; } @@ -3771,93 +3771,93 @@ Perl_moreswitches(pTHX_ const char *s) STATIC void S_minus_v(pTHX) { - PerlIO * PIO_stdout; - { - const char * const level_str = "v" PERL_VERSION_STRING; - const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; + PerlIO * PIO_stdout; + { + const char * const level_str = "v" PERL_VERSION_STRING; + const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; #ifdef PERL_PATCHNUM - SV* level; + SV* level; # ifdef PERL_GIT_UNCOMMITTED_CHANGES - static const char num [] = PERL_PATCHNUM "*"; + static const char num [] = PERL_PATCHNUM "*"; # else - static const char num [] = PERL_PATCHNUM; + static const char num [] = PERL_PATCHNUM; # endif - { - const STRLEN num_len = sizeof(num)-1; - /* A very advanced compiler would fold away the strnEQ - and this whole conditional, but most (all?) won't do it. - SV level could also be replaced by with preprocessor - catenation. - */ - if (num_len >= level_len && strnEQ(num,level_str,level_len)) { - /* per 46807d8e80, PERL_PATCHNUM is outside of the control - of the interp so it might contain format characters - */ - level = newSVpvn(num, num_len); - } else { - level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); - } - } + { + const STRLEN num_len = sizeof(num)-1; + /* A very advanced compiler would fold away the strnEQ + and this whole conditional, but most (all?) won't do it. + SV level could also be replaced by with preprocessor + catenation. + */ + if (num_len >= level_len && strnEQ(num,level_str,level_len)) { + /* per 46807d8e80, PERL_PATCHNUM is outside of the control + of the interp so it might contain format characters + */ + level = newSVpvn(num, num_len); + } else { + level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); + } + } #else - SV* level = newSVpvn(level_str, level_len); + SV* level = newSVpvn(level_str, level_len); #endif /* #ifdef PERL_PATCHNUM */ - PIO_stdout = PerlIO_stdout(); - PerlIO_printf(PIO_stdout, - "\nThis is perl " STRINGIFY(PERL_REVISION) - ", version " STRINGIFY(PERL_VERSION) - ", subversion " STRINGIFY(PERL_SUBVERSION) - " (%" SVf ") built for " ARCHNAME, SVfARG(level) - ); - SvREFCNT_dec_NN(level); - } + PIO_stdout = PerlIO_stdout(); + PerlIO_printf(PIO_stdout, + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%" SVf ") built for " ARCHNAME, SVfARG(level) + ); + SvREFCNT_dec_NN(level); + } #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) - PerlIO_printf(PIO_stdout, - "\n(with %d registered patch%s, " - "see perl -V for more detail)", - LOCAL_PATCH_COUNT, - (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + if (LOCAL_PATCH_COUNT > 0) + PerlIO_printf(PIO_stdout, + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2021, Larry Wall\n"); + PerlIO_printf(PIO_stdout, + "\n\nCopyright 1987-2021, Larry Wall\n"); #ifdef MSDOS - PerlIO_printf(PIO_stdout, - "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PIO_stdout, + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - PerlIO_printf(PIO_stdout, - "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" - "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PIO_stdout, + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - PerlIO_printf(PIO_stdout, - "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PIO_stdout, + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef OEMVS - PerlIO_printf(PIO_stdout, - "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PIO_stdout, + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - PerlIO_printf(PIO_stdout, - "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); + PerlIO_printf(PIO_stdout, + "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); #endif #ifdef POSIX_BC - PerlIO_printf(PIO_stdout, - "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PIO_stdout, + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef BINARY_BUILD_NOTICE - BINARY_BUILD_NOTICE; + BINARY_BUILD_NOTICE; #endif - PerlIO_printf(PIO_stdout, - "\n\ + PerlIO_printf(PIO_stdout, + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); - my_exit(0); + my_exit(0); } /* compliments of Tom Christiansen */ @@ -3950,7 +3950,7 @@ S_init_main_stash(pTHX) GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, - SVt_PVAV))); + SVt_PVAV))); SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ @@ -3973,7 +3973,7 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, - SVt_PVHV)); + SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvs(get_sv("/", GV_ADD), "\n"); } @@ -3989,102 +3989,102 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) PERL_ARGS_ASSERT_OPEN_SCRIPT; if (PL_e_script) { - PL_origfilename = savepvs("-e"); + PL_origfilename = savepvs("-e"); } else { const char *s; UV uv; - /* if find_script() returns, it returns a malloc()-ed value */ - scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + /* if find_script() returns, it returns a malloc()-ed value */ + scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); s = scriptname + strlen(scriptname); - if (strBEGINs(scriptname, "/dev/fd/") + if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX ) { fdscript = (int)uv; - if (*s) { - /* PSz 18 Feb 04 - * Tell apart "normal" usage of fdscript, e.g. - * with bash on FreeBSD: - * perl <( echo '#!perl -DA'; echo 'print "$0\n"') - * from usage in suidperl. - * Does any "normal" usage leave garbage after the number??? - * Is it a mistake to use a similar /dev/fd/ construct for - * suidperl? - */ - *suidscript = TRUE; - /* PSz 20 Feb 04 - * Be supersafe and do some sanity-checks. - * Still, can we be sure we got the right thing? - */ - if (*s != '/') { - Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); - } - if (! *(s+1)) { - Perl_croak(aTHX_ "Missing (suid) fd script name\n"); - } - scriptname = savepv(s + 1); - Safefree(PL_origfilename); - PL_origfilename = (char *)scriptname; - } - } + if (*s) { + /* PSz 18 Feb 04 + * Tell apart "normal" usage of fdscript, e.g. + * with bash on FreeBSD: + * perl <( echo '#!perl -DA'; echo 'print "$0\n"') + * from usage in suidperl. + * Does any "normal" usage leave garbage after the number??? + * Is it a mistake to use a similar /dev/fd/ construct for + * suidperl? + */ + *suidscript = TRUE; + /* PSz 20 Feb 04 + * Be supersafe and do some sanity-checks. + * Still, can we be sure we got the right thing? + */ + if (*s != '/') { + Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); + } + if (! *(s+1)) { + Perl_croak(aTHX_ "Missing (suid) fd script name\n"); + } + scriptname = savepv(s + 1); + Safefree(PL_origfilename); + PL_origfilename = (char *)scriptname; + } + } } CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') - scriptname = (char *)""; + scriptname = (char *)""; if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); } else if (!*scriptname) { - forbid_setid(0, *suidscript); - return NULL; + forbid_setid(0, *suidscript); + return NULL; } else { #ifdef FAKE_BIT_BUCKET - /* This hack allows one not to have /dev/null (or BIT_BUCKET as it - * is called) and still have the "-e" work. (Believe it or not, - * a /dev/null is required for the "-e" to work because source - * filter magic is used to implement it. ) This is *not* a general - * replacement for a /dev/null. What we do here is create a temp - * file (an empty file), open up that as the script, and then - * immediately close and unlink it. Close enough for jazz. */ + /* This hack allows one not to have /dev/null (or BIT_BUCKET as it + * is called) and still have the "-e" work. (Believe it or not, + * a /dev/null is required for the "-e" to work because source + * filter magic is used to implement it. ) This is *not* a general + * replacement for a /dev/null. What we do here is create a temp + * file (an empty file), open up that as the script, and then + * immediately close and unlink it. Close enough for jazz. */ #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX - char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { - FAKE_BIT_BUCKET_TEMPLATE - }; - const char * const err = "Failed to create a fake bit bucket"; - if (strEQ(scriptname, BIT_BUCKET)) { - int tmpfd = Perl_my_mkstemp_cloexec(tmpname); - if (tmpfd > -1) { - scriptname = tmpname; - close(tmpfd); - } else - Perl_croak(aTHX_ err); - } -#endif - rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); + char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { + FAKE_BIT_BUCKET_TEMPLATE + }; + const char * const err = "Failed to create a fake bit bucket"; + if (strEQ(scriptname, BIT_BUCKET)) { + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); + if (tmpfd > -1) { + scriptname = tmpname; + close(tmpfd); + } else + Perl_croak(aTHX_ err); + } +#endif + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #ifdef FAKE_BIT_BUCKET if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX) - && strlen(scriptname) == sizeof(tmpname) - 1) + && strlen(scriptname) == sizeof(tmpname) - 1) { - unlink(scriptname); - } - scriptname = BIT_BUCKET; + unlink(scriptname); + } + scriptname = BIT_BUCKET; #endif } if (!rsfp) { - /* PSz 16 Sep 03 Keep neat error message */ - if (PL_e_script) - Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); - else - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); + /* PSz 16 Sep 03 Keep neat error message */ + if (PL_e_script) + Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); + else + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); @@ -4137,10 +4137,10 @@ S_validate_suid(pTHX_ PerlIO *rsfp) || (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) - if (!PL_do_undump) - Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + if (!PL_do_undump) + Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); - /* not set-id, must be wrapped */ + /* not set-id, must be wrapped */ } } #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ @@ -4156,20 +4156,20 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) /* skip forward in input to the real script? */ do { - if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) - Perl_croak(aTHX_ "No Perl script found in input\n"); - s2 = s; + if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) + Perl_croak(aTHX_ "No Perl script found in input\n"); + s2 = s; } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; while (*s == ' ' || *s == '\t') s++; if (*s++ == '-') { - while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' - || s2[-1] == '_') s2--; - if (strBEGINs(s2-4,"perl")) - while ((s = moreswitches(s))) - ; + while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' + || s2[-1] == '_') s2--; + if (strBEGINs(s2-4,"perl")) + while ((s = moreswitches(s))) + ; } } @@ -4228,14 +4228,14 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) euid |= egid << 16; #endif if (uid && (euid != uid || egid != gid)) - return 1; + return 1; #endif /* !PERL_IMPLICIT_SYS */ /* This is a really primitive check; environment gets ignored only * if -T are the first chars together; otherwise one gets * "Too late" message. */ if ( argc > 1 && argv[1][0] == '-' && isALPHA_FOLD_EQ(argv[1][1], 't')) - return 1; + return 1; return 0; } @@ -4251,8 +4251,8 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ PERL_UNUSED_CONTEXT; if (flag) { - string[1] = flag; - message = string; + string[1] = flag; + message = string; } #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -4269,16 +4269,16 @@ void Perl_init_dbargs(pTHX) { AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", - GV_ADDMULTI, - SVt_PVAV)))); + GV_ADDMULTI, + SVt_PVAV)))); if (AvREAL(args)) { - /* Someone has already created it. - It might have entries, and if we just turn off AvREAL(), they will - "leak" until global destruction. */ - av_clear(args); - if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) - Perl_croak(aTHX_ "Cannot set tied @DB::args"); + /* Someone has already created it. + It might have entries, and if we just turn off AvREAL(), they will + "leak" until global destruction. */ + av_clear(args); + if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) + Perl_croak(aTHX_ "Cannot set tied @DB::args"); } AvREIFY_only(PL_dbargs); } @@ -4293,31 +4293,31 @@ Perl_init_debugger(pTHX) Perl_init_dbargs(aTHX); PL_DBgv = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) + SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) ); PL_DBline = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) + SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) ); PL_DBsub = MUTABLE_GV(SvREFCNT_inc( - gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) + gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) )); PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsingle)) - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SINGLE; SvSETMAGIC(PL_DBsingle); PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBtrace)) - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_TRACE; SvSETMAGIC(PL_DBtrace); PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SIGNAL; SvSETMAGIC(PL_DBsignal); @@ -4341,7 +4341,7 @@ Perl_init_stacks(pTHX) /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), - REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); PL_curstackinfo->si_type = PERLSI_MAIN; #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY PL_curstackinfo->si_stack_hwm = 0; @@ -4384,13 +4384,13 @@ STATIC void S_nuke_stacks(pTHX) { while (PL_curstackinfo->si_next) - PL_curstackinfo = PL_curstackinfo->si_next; + PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { - PERL_SI *p = PL_curstackinfo->si_prev; - /* curstackinfo->si_stack got nuked by sv_free_arenas() */ - Safefree(PL_curstackinfo->si_cxstack); - Safefree(PL_curstackinfo); - PL_curstackinfo = p; + PERL_SI *p = PL_curstackinfo->si_prev; + /* curstackinfo->si_stack got nuked by sv_free_arenas() */ + Safefree(PL_curstackinfo->si_cxstack); + Safefree(PL_curstackinfo); + PL_curstackinfo = p; } Safefree(PL_tmps_stack); Safefree(PL_markstack); @@ -4411,25 +4411,25 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) PERL_ARGS_ASSERT_POPULATE_ISA; if(AvFILLp(isa) != -1) - return; + return; /* NOTE: No support for tied ISA */ va_start(args, len); do { - const char *const parent = va_arg(args, const char*); - size_t parent_len; - - if (!parent) - break; - parent_len = va_arg(args, size_t); - - /* Arguments are supplied with a trailing :: */ - assert(parent_len > 2); - assert(parent[parent_len - 1] == ':'); - assert(parent[parent_len - 2] == ':'); - av_push(isa, newSVpvn(parent, parent_len - 2)); - (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); + const char *const parent = va_arg(args, const char*); + size_t parent_len; + + if (!parent) + break; + parent_len = va_arg(args, size_t); + + /* Arguments are supplied with a trailing :: */ + assert(parent_len > 2); + assert(parent[parent_len - 1] == ':'); + assert(parent[parent_len - 2] == ':'); + av_push(isa, newSVpvn(parent, parent_len - 2)); + (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); } while (1); va_end(args); } @@ -4457,12 +4457,12 @@ S_init_predump_symbols(pTHX) So a compromise is to set up the correct @IO::File::ISA, so that code that does C; will still work. */ - + Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), - STR_WITH_LEN("IO::Handle::"), - STR_WITH_LEN("IO::Seekable::"), - STR_WITH_LEN("Exporter::"), - NULL); + STR_WITH_LEN("IO::Handle::"), + STR_WITH_LEN("IO::Seekable::"), + STR_WITH_LEN("Exporter::"), + NULL); PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); @@ -4502,37 +4502,37 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) argc--,argv++; /* skip name of script */ if (PL_doswitches) { - for (; argc > 0 && **argv == '-'; argc--,argv++) { - char *s; - if (!argv[0][1]) - break; - if (argv[0][1] == '-' && !argv[0][2]) { - argc--,argv++; - break; - } - if ((s = strchr(argv[0], '='))) { - const char *const start_name = argv[0] + 1; - sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, - TRUE, SVt_PV)), s + 1); - } - else - sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); - } + for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; + if (!argv[0][1]) + break; + if (argv[0][1] == '-' && !argv[0][2]) { + argc--,argv++; + break; + } + if ((s = strchr(argv[0], '='))) { + const char *const start_name = argv[0] + 1; + sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, + TRUE, SVt_PV)), s + 1); + } + else + sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); + } } if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { - SvREFCNT_inc_simple_void_NN(PL_argvgv); - GvMULTI_on(PL_argvgv); - av_clear(GvAVn(PL_argvgv)); - for (; argc > 0; argc--,argv++) { - SV * const sv = newSVpv(argv[0],0); - av_push(GvAV(PL_argvgv),sv); - if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { - if (PL_unicode & PERL_UNICODE_ARGV_FLAG) - SvUTF8_on(sv); - } - if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ - (void)sv_utf8_decode(sv); - } + SvREFCNT_inc_simple_void_NN(PL_argvgv); + GvMULTI_on(PL_argvgv); + av_clear(GvAVn(PL_argvgv)); + for (; argc > 0; argc--,argv++) { + SV * const sv = newSVpv(argv[0],0); + av_push(GvAV(PL_argvgv),sv); + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + if (PL_unicode & PERL_UNICODE_ARGV_FLAG) + SvUTF8_on(sv); + } + if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ + (void)sv_utf8_decode(sv); + } } if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) @@ -4559,50 +4559,50 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) init_argv_symbols(argc,argv); if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { - sv_setpv(GvSV(tmpgv),PL_origfilename); + sv_setpv(GvSV(tmpgv),PL_origfilename); } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { - HV *hv; - bool env_is_not_environ; - SvREFCNT_inc_simple_void_NN(PL_envgv); - GvMULTI_on(PL_envgv); - hv = GvHVn(PL_envgv); - hv_magic(hv, NULL, PERL_MAGIC_env); + HV *hv; + bool env_is_not_environ; + SvREFCNT_inc_simple_void_NN(PL_envgv); + GvMULTI_on(PL_envgv); + hv = GvHVn(PL_envgv); + hv_magic(hv, NULL, PERL_MAGIC_env); #ifndef PERL_MICRO #ifdef USE_ENVIRON_ARRAY - /* Note that if the supplied env parameter is actually a copy - of the global environ then it may now point to free'd memory - if the environment has been modified since. To avoid this - problem we treat env==NULL as meaning 'use the default' - */ - if (!env) - env = environ; - env_is_not_environ = env != environ; - if (env_is_not_environ + /* Note that if the supplied env parameter is actually a copy + of the global environ then it may now point to free'd memory + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; + env_is_not_environ = env != environ; + if (env_is_not_environ # ifdef USE_ITHREADS - && PL_curinterp == aTHX + && PL_curinterp == aTHX # endif - ) - { - environ[0] = NULL; - } - if (env) { - char *s, *old_var; + ) + { + environ[0] = NULL; + } + if (env) { + char *s, *old_var; STRLEN nlen; - SV *sv; + SV *sv; HV *dups = newHV(); - for (; *env; env++) { - old_var = *env; + for (; *env; env++) { + old_var = *env; - if (!(s = strchr(old_var,'=')) || s == old_var) - continue; + if (!(s = strchr(old_var,'=')) || s == old_var) + continue; nlen = s - old_var; #if defined(MSDOS) && !defined(DJGPP) - *s = '\0'; - (void)strupr(old_var); - *s = '='; + *s = '\0'; + (void)strupr(old_var); + *s = '='; #endif if (hv_exists(hv, old_var, nlen)) { const char *name = savepvn(old_var, nlen); @@ -4623,10 +4623,10 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) else { sv = newSVpv(s+1, 0); } - (void)hv_store(hv, old_var, nlen, sv, 0); - if (env_is_not_environ) - mg_set(sv); - } + (void)hv_store(hv, old_var, nlen, sv, 0); + if (env_is_not_environ) + mg_set(sv); + } if (HvKEYS(dups)) { /* environ has some duplicate definitions, remove them */ HE *entry; @@ -4677,38 +4677,38 @@ S_init_perllib(pTHX) if (!TAINTING_get) { #ifndef VMS - perl5lib = PerlEnv_getenv("PERL5LIB"); + perl5lib = PerlEnv_getenv("PERL5LIB"); /* * It isn't possible to delete an environment variable with * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that * case we treat PERL5LIB as undefined if it has a zero-length value. */ #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) - if (perl5lib && *perl5lib != '\0') + if (perl5lib && *perl5lib != '\0') #else - if (perl5lib) -#endif - incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); - else { - s = PerlEnv_getenv("PERLLIB"); - if (s) - incpush_use_sep(s, 0, 0); - } + if (perl5lib) +#endif + incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); + else { + s = PerlEnv_getenv("PERLLIB"); + if (s) + incpush_use_sep(s, 0, 0); + } #else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ - char buf[256]; - int idx = 0; - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) - do { - incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); - else { - while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) - incpush_use_sep(buf, 0, 0); - } + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ + char buf[256]; + int idx = 0; + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) + do { + incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); + else { + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) + incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } @@ -4768,12 +4768,12 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) { - av_push(av, dir); - dir = newSVsv(stem); + S_ISDIR(tmpstatbuf.st_mode)) { + av_push(av, dir); + dir = newSVsv(stem); } else { - /* Truncate dir back to stem. */ - SvCUR_set(dir, SvCUR(stem)); + /* Truncate dir back to stem. */ + SvCUR_set(dir, SvCUR(stem)); } return dir; } @@ -4797,120 +4797,120 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) #ifdef VMS { - char *unix; + char *unix; - if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { - len = strlen(unix); - while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ - sv_usepvn(libdir,unix,len); - } - else - PerlIO_printf(Perl_error_log, - "Failed to unixify @INC element \"%s\"\n", - SvPV_nolen_const(libdir)); + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { + len = strlen(unix); + while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ + sv_usepvn(libdir,unix,len); + } + else + PerlIO_printf(Perl_error_log, + "Failed to unixify @INC element \"%s\"\n", + SvPV_nolen_const(libdir)); } #endif - /* Do the if() outside the #ifdef to avoid warnings about an unused - parameter. */ - if (canrelocate) { + /* Do the if() outside the #ifdef to avoid warnings about an unused + parameter. */ + if (canrelocate) { #ifdef PERL_RELOCATABLE_INC - /* - * Relocatable include entries are marked with a leading .../ - * - * The algorithm is - * 0: Remove that leading ".../" - * 1: Remove trailing executable name (anything after the last '/') - * from the perl path to give a perl prefix - * Then - * While the @INC element starts "../" and the prefix ends with a real - * directory (ie not . or ..) chop that real directory off the prefix - * and the leading "../" from the @INC element. ie a logical "../" - * cleanup - * Finally concatenate the prefix and the remainder of the @INC element - * The intent is that /usr/local/bin/perl and .../../lib/perl5 - * generates /usr/local/lib/perl5 - */ - const char *libpath = SvPVX(libdir); - STRLEN libpath_len = SvCUR(libdir); - if (memBEGINs(libpath, libpath_len, ".../")) { - /* Game on! */ - SV * const caret_X = get_sv("\030", 0); - /* Going to use the SV just as a scratch buffer holding a C - string: */ - SV *prefix_sv; - char *prefix; - char *lastslash; - - /* $^X is *the* source of taint if tainting is on, hence - SvPOK() won't be true. */ - assert(caret_X); - assert(SvPOKp(caret_X)); - prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), - SvUTF8(caret_X)); - /* Firstly take off the leading .../ - If all else fail we'll do the paths relative to the current - directory. */ - sv_chop(libdir, libpath + 4); - /* Don't use SvPV as we're intentionally bypassing taining, - mortal copies that the mg_get of tainting creates, and - corruption that seems to come via the save stack. - I guess that the save stack isn't correctly set up yet. */ - libpath = SvPVX(libdir); - libpath_len = SvCUR(libdir); - - prefix = SvPVX(prefix_sv); - lastslash = (char *) my_memrchr(prefix, '/', + /* + * Relocatable include entries are marked with a leading .../ + * + * The algorithm is + * 0: Remove that leading ".../" + * 1: Remove trailing executable name (anything after the last '/') + * from the perl path to give a perl prefix + * Then + * While the @INC element starts "../" and the prefix ends with a real + * directory (ie not . or ..) chop that real directory off the prefix + * and the leading "../" from the @INC element. ie a logical "../" + * cleanup + * Finally concatenate the prefix and the remainder of the @INC element + * The intent is that /usr/local/bin/perl and .../../lib/perl5 + * generates /usr/local/lib/perl5 + */ + const char *libpath = SvPVX(libdir); + STRLEN libpath_len = SvCUR(libdir); + if (memBEGINs(libpath, libpath_len, ".../")) { + /* Game on! */ + SV * const caret_X = get_sv("\030", 0); + /* Going to use the SV just as a scratch buffer holding a C + string: */ + SV *prefix_sv; + char *prefix; + char *lastslash; + + /* $^X is *the* source of taint if tainting is on, hence + SvPOK() won't be true. */ + assert(caret_X); + assert(SvPOKp(caret_X)); + prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), + SvUTF8(caret_X)); + /* Firstly take off the leading .../ + If all else fail we'll do the paths relative to the current + directory. */ + sv_chop(libdir, libpath + 4); + /* Don't use SvPV as we're intentionally bypassing taining, + mortal copies that the mg_get of tainting creates, and + corruption that seems to come via the save stack. + I guess that the save stack isn't correctly set up yet. */ + libpath = SvPVX(libdir); + libpath_len = SvCUR(libdir); + + prefix = SvPVX(prefix_sv); + lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix); - /* First time in with the *lastslash = '\0' we just wipe off - the trailing /perl from (say) /usr/foo/bin/perl - */ - if (lastslash) { - SV *tempsv; - while ((*lastslash = '\0'), /* Do that, come what may. */ + /* First time in with the *lastslash = '\0' we just wipe off + the trailing /perl from (say) /usr/foo/bin/perl + */ + if (lastslash) { + SV *tempsv; + while ((*lastslash = '\0'), /* Do that, come what may. */ ( memBEGINs(libpath, libpath_len, "../") - && (lastslash = + && (lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix)))) { - if (lastslash[1] == '\0' - || (lastslash[1] == '.' - && (lastslash[2] == '/' /* ends "/." */ - || (lastslash[2] == '/' - && lastslash[3] == '/' /* or "/.." */ - )))) { - /* Prefix ends "/" or "/." or "/..", any of which - are fishy, so don't do any more logical cleanup. - */ - break; - } - /* Remove leading "../" from path */ - libpath += 3; - libpath_len -= 3; - /* Next iteration round the loop removes the last - directory name from prefix by writing a '\0' in - the while clause. */ - } - /* prefix has been terminated with a '\0' to the correct - length. libpath points somewhere into the libdir SV. - We need to join the 2 with '/' and drop the result into - libdir. */ - tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); - SvREFCNT_dec(libdir); - /* And this is the new libdir. */ - libdir = tempsv; - if (TAINTING_get && - (PerlProc_getuid() != PerlProc_geteuid() || - PerlProc_getgid() != PerlProc_getegid())) { - /* Need to taint relocated paths if running set ID */ - SvTAINTED_on(libdir); - } - } - SvREFCNT_dec(prefix_sv); - } -#endif - } + if (lastslash[1] == '\0' + || (lastslash[1] == '.' + && (lastslash[2] == '/' /* ends "/." */ + || (lastslash[2] == '/' + && lastslash[3] == '/' /* or "/.." */ + )))) { + /* Prefix ends "/" or "/." or "/..", any of which + are fishy, so don't do any more logical cleanup. + */ + break; + } + /* Remove leading "../" from path */ + libpath += 3; + libpath_len -= 3; + /* Next iteration round the loop removes the last + directory name from prefix by writing a '\0' in + the while clause. */ + } + /* prefix has been terminated with a '\0' to the correct + length. libpath points somewhere into the libdir SV. + We need to join the 2 with '/' and drop the result into + libdir. */ + tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); + SvREFCNT_dec(libdir); + /* And this is the new libdir. */ + libdir = tempsv; + if (TAINTING_get && + (PerlProc_getuid() != PerlProc_geteuid() || + PerlProc_getgid() != PerlProc_getegid())) { + /* Need to taint relocated paths if running set ID */ + SvTAINTED_on(libdir); + } + } + SvREFCNT_dec(prefix_sv); + } +#endif + } return libdir; } @@ -4919,12 +4919,12 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { #ifndef PERL_IS_MINIPERL const U8 using_sub_dirs - = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS - |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); + = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS + |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); const U8 add_versioned_sub_dirs - = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; const U8 add_archonly_sub_dirs - = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; #ifdef PERL_INC_VERSION_LIST const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; #endif @@ -4939,95 +4939,95 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) /* Could remove this vestigial extra block, if we don't mind a lot of re-indenting diff noise. */ { - SV *const libdir = mayberelocate(dir, len, flags); - /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, - arranged to unshift #! line -I onto the front of @INC. However, - -I can add version and architecture specific libraries, and they - need to go first. The old code assumed that it was always - pushing. Hence to make it work, need to push the architecture - (etc) libraries onto a temporary array, then "unshift" that onto - the front of @INC. */ + SV *const libdir = mayberelocate(dir, len, flags); + /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, + arranged to unshift #! line -I onto the front of @INC. However, + -I can add version and architecture specific libraries, and they + need to go first. The old code assumed that it was always + pushing. Hence to make it work, need to push the architecture + (etc) libraries onto a temporary array, then "unshift" that onto + the front of @INC. */ #ifndef PERL_IS_MINIPERL - AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; - - /* - * BEFORE pushing libdir onto @INC we may first push version- and - * archname-specific sub-directories. - */ - if (using_sub_dirs) { - SV *subdir = newSVsv(libdir); + AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; + + /* + * BEFORE pushing libdir onto @INC we may first push version- and + * archname-specific sub-directories. + */ + if (using_sub_dirs) { + SV *subdir = newSVsv(libdir); #ifdef PERL_INC_VERSION_LIST - /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char * const incverlist[] = { PERL_INC_VERSION_LIST }; - const char * const *incver; + /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif - if (add_versioned_sub_dirs) { - /* .../version/archname if -d .../version/archname */ - sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_versioned_sub_dirs) { + /* .../version/archname if -d .../version/archname */ + sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - /* .../version if -d .../version */ - sv_catpvs(subdir, "/" PERL_FS_VERSION); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + /* .../version if -d .../version */ + sv_catpvs(subdir, "/" PERL_FS_VERSION); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } #ifdef PERL_INC_VERSION_LIST - if (addoldvers) { - for (incver = incverlist; *incver; incver++) { - /* .../xxx if -d .../xxx */ - Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } - } + if (addoldvers) { + for (incver = incverlist; *incver; incver++) { + /* .../xxx if -d .../xxx */ + Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } + } #endif - if (add_archonly_sub_dirs) { - /* .../archname if -d .../archname */ - sv_catpvs(subdir, "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_archonly_sub_dirs) { + /* .../archname if -d .../archname */ + sv_catpvs(subdir, "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + } - assert (SvREFCNT(subdir) == 1); - SvREFCNT_dec(subdir); - } + assert (SvREFCNT(subdir) == 1); + SvREFCNT_dec(subdir); + } #endif /* !PERL_IS_MINIPERL */ - /* finally add this lib directory at the end of @INC */ - if (unshift) { + /* finally add this lib directory at the end of @INC */ + if (unshift) { #ifdef PERL_IS_MINIPERL - const Size_t extra = 0; + const Size_t extra = 0; #else - Size_t extra = av_count(av); + Size_t extra = av_count(av); #endif - av_unshift(inc, extra + push_basedir); - if (push_basedir) - av_store(inc, extra, libdir); + av_unshift(inc, extra + push_basedir); + if (push_basedir) + av_store(inc, extra, libdir); #ifndef PERL_IS_MINIPERL - while (extra--) { - /* av owns a reference, av_store() expects to be donated a - reference, and av expects to be sane when it's cleared. - If I wanted to be naughty and wrong, I could peek inside the - implementation of av_clear(), realise that it uses - SvREFCNT_dec() too, so av's array could be a run of NULLs, - and so directly steal from it (with a memcpy() to inc, and - then memset() to NULL them out. But people copy code from the - core expecting it to be best practise, so let's use the API. - Although studious readers will note that I'm not checking any - return codes. */ - av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); - } - SvREFCNT_dec(av); -#endif - } - else if (push_basedir) { - av_push(inc, libdir); - } - - if (!push_basedir) { - assert (SvREFCNT(libdir) == 1); - SvREFCNT_dec(libdir); - } + while (extra--) { + /* av owns a reference, av_store() expects to be donated a + reference, and av expects to be sane when it's cleared. + If I wanted to be naughty and wrong, I could peek inside the + implementation of av_clear(), realise that it uses + SvREFCNT_dec() too, so av's array could be a run of NULLs, + and so directly steal from it (with a memcpy() to inc, and + then memset() to NULL them out. But people copy code from the + core expecting it to be best practise, so let's use the API. + Although studious readers will note that I'm not checking any + return codes. */ + av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); + } + SvREFCNT_dec(av); +#endif + } + else if (push_basedir) { + av_push(inc, libdir); + } + + if (!push_basedir) { + assert (SvREFCNT(libdir) == 1); + SvREFCNT_dec(libdir); + } } } @@ -5050,25 +5050,25 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) #ifndef PERL_RELOCATABLE_INCPUSH if (!len) #endif - len = strlen(p); + len = strlen(p); end = p + len; /* Break at all separators */ while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { - if (s == p) { - /* skip any consecutive separators */ + if (s == p) { + /* skip any consecutive separators */ - /* Uncomment the next line for PATH semantics */ - /* But you'll need to write tests */ - /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ - } else { - incpush(p, (STRLEN)(s - p), flags); - } - p = s + 1; + /* Uncomment the next line for PATH semantics */ + /* But you'll need to write tests */ + /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ + } else { + incpush(p, (STRLEN)(s - p), flags); + } + p = s + 1; } if (p != end) - incpush(p, (STRLEN)(end - p), flags); + incpush(p, (STRLEN)(end - p), flags); } @@ -5085,72 +5085,72 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PERL_ARGS_ASSERT_CALL_LIST; while (av_count(paramList) > 0) { - cv = MUTABLE_CV(av_shift(paramList)); - if (PL_savebegin) { - if (paramList == PL_beginav) { - /* save PL_beginav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_checkav) { - /* save PL_checkav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_unitcheckav) { - /* save PL_unitcheckav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); - } - } else { + cv = MUTABLE_CV(av_shift(paramList)); + if (PL_savebegin) { + if (paramList == PL_beginav) { + /* save PL_beginav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_checkav) { + /* save PL_checkav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_unitcheckav) { + /* save PL_unitcheckav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); + } + } else { SAVEFREESV(cv); - } - JMPENV_PUSH(ret); - switch (ret) { - case 0: - CALL_LIST_BODY(cv); - atsv = ERRSV; - (void)SvPV_const(atsv, len); - if (len) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - if (paramList == PL_beginav) - sv_catpvs(atsv, "BEGIN failed--compilation aborted"); - else - Perl_sv_catpvf(aTHX_ atsv, - "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - while (PL_scopestack_ix > oldscope) - LEAVE; - JMPENV_POP; - Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_JUMP(3); - } - PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); - FREETMPS; - break; - } - JMPENV_POP; + } + JMPENV_PUSH(ret); + switch (ret) { + case 0: + CALL_LIST_BODY(cv); + atsv = ERRSV; + (void)SvPV_const(atsv, len); + if (len) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + if (paramList == PL_beginav) + sv_catpvs(atsv, "BEGIN failed--compilation aborted"); + else + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : paramList == PL_unitcheckav ? "UNITCHECK" + : "END"); + while (PL_scopestack_ix > oldscope) + LEAVE; + JMPENV_POP; + Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_JUMP(3); + } + PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); + FREETMPS; + break; + } + JMPENV_POP; } } @@ -5167,23 +5167,23 @@ void Perl_my_exit(pTHX_ U32 status) { if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); + PL_exit_flags &= ~PERL_EXIT_ABORT; } switch (status) { case 0: - STATUS_ALL_SUCCESS; - break; + STATUS_ALL_SUCCESS; + break; case 1: - STATUS_ALL_FAILURE; - break; + STATUS_ALL_FAILURE; + break; default: - STATUS_EXIT_SET(status); - break; + STATUS_EXIT_SET(status); + break; } my_exit_jump(); } @@ -5204,80 +5204,80 @@ Perl_my_failure_exit(pTHX) /* According to the die_exit.t tests, if errno is non-zero */ /* It should be used for the error status. */ - if (errno == EVMSERR) { - STATUS_NATIVE = vaxc$errno; - } else { + if (errno == EVMSERR) { + STATUS_NATIVE = vaxc$errno; + } else { /* According to die_exit.t tests, if the child_exit code is */ /* also zero, then we need to exit with a code of 255 */ if ((errno != 0) && (errno < 256)) - STATUS_UNIX_EXIT_SET(errno); + STATUS_UNIX_EXIT_SET(errno); else if (STATUS_UNIX < 255) { - STATUS_UNIX_EXIT_SET(255); + STATUS_UNIX_EXIT_SET(255); } - } - - /* The exit code could have been set by $? or vmsish which - * means that it may not have fatal set. So convert - * success/warning codes to fatal with out changing - * the POSIX status code. The severity makes VMS native - * status handling work, while UNIX mode programs use the - * POSIX exit codes. - */ - if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { - STATUS_NATIVE &= STS$M_COND_ID; - STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; + } + + /* The exit code could have been set by $? or vmsish which + * means that it may not have fatal set. So convert + * success/warning codes to fatal with out changing + * the POSIX status code. The severity makes VMS native + * status handling work, while UNIX mode programs use the + * POSIX exit codes. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { + STATUS_NATIVE &= STS$M_COND_ID; + STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; } } else { - /* Traditionally Perl on VMS always expects a Fatal Error. */ - if (vaxc$errno & 1) { - - /* So force success status to failure */ - if (STATUS_NATIVE & 1) - STATUS_ALL_FAILURE; - } - else { - if (!vaxc$errno) { - STATUS_UNIX = EINTR; /* In case something cares */ - STATUS_ALL_FAILURE; - } - else { - int severity; - STATUS_NATIVE = vaxc$errno; /* Should already be this */ - - /* Encode the severity code */ - severity = STATUS_NATIVE & STS$M_SEVERITY; - STATUS_UNIX = (severity ? severity : 1) << 8; - - /* Perl expects this to be a fatal error */ - if (severity != STS$K_SEVERE) - STATUS_ALL_FAILURE; - } - } + /* Traditionally Perl on VMS always expects a Fatal Error. */ + if (vaxc$errno & 1) { + + /* So force success status to failure */ + if (STATUS_NATIVE & 1) + STATUS_ALL_FAILURE; + } + else { + if (!vaxc$errno) { + STATUS_UNIX = EINTR; /* In case something cares */ + STATUS_ALL_FAILURE; + } + else { + int severity; + STATUS_NATIVE = vaxc$errno; /* Should already be this */ + + /* Encode the severity code */ + severity = STATUS_NATIVE & STS$M_SEVERITY; + STATUS_UNIX = (severity ? severity : 1) << 8; + + /* Perl expects this to be a fatal error */ + if (severity != STS$K_SEVERE) + STATUS_ALL_FAILURE; + } + } } #else int exitstatus; int eno = errno; if (eno & 255) - STATUS_UNIX_SET(eno); + STATUS_UNIX_SET(eno); else { - exitstatus = STATUS_UNIX >> 8; - if (exitstatus & 255) - STATUS_UNIX_SET(exitstatus); - else - STATUS_UNIX_SET(255); + exitstatus = STATUS_UNIX >> 8; + if (exitstatus & 255) + STATUS_UNIX_SET(exitstatus); + else + STATUS_UNIX_SET(255); } #endif if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); + PL_exit_flags &= ~PERL_EXIT_ABORT; } my_exit_jump(); } @@ -5286,8 +5286,8 @@ STATIC void S_my_exit_jump(pTHX) { if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } POPSTACK_TO(PL_mainstack); @@ -5312,8 +5312,8 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) nl = (nl) ? nl+1 : e; if (nl-p == 0) { - filter_del(read_e_script); - return 0; + filter_del(read_e_script); + return 0; } sv_catpvn(buf_sv, p, nl-p); sv_chop(PL_e_script, nl); @@ -5325,7 +5325,7 @@ void Perl_xs_boot_epilog(pTHX_ const I32 ax) { if (PL_unitcheckav) - call_list(PL_scopestack_ix, PL_unitcheckav); + call_list(PL_scopestack_ix, PL_unitcheckav); XSRETURN_YES; } diff --git a/perl.h b/perl.h index 17a21a1c420f..4c074e58b444 100644 --- a/perl.h +++ b/perl.h @@ -481,7 +481,7 @@ compilation causes it be used just some times. */ #if defined(PERL_GCC_PEDANTIC) || \ (defined(__GNUC__) && defined(__cplusplus) && \ - ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2)))) + ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2)))) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif @@ -1361,20 +1361,20 @@ Use L to declare variables of the maximum usable size on this platform. # define saferealloc Perl_realloc # define safefree Perl_mfree # define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \ - if (!TAINTING_get && MallocCfg_ptr[MallocCfg_cfg_env_read]) \ - code; \ + if (!TAINTING_get && MallocCfg_ptr[MallocCfg_cfg_env_read]) \ + code; \ } STMT_END # define CHECK_MALLOC_TOO_LATE_FOR(ch) \ - CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch)) + CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch)) # define panic_write2(s) write(2, s, strlen(s)) # define CHECK_MALLOC_TAINT(newval) \ - CHECK_MALLOC_TOO_LATE_FOR_( \ - if (newval) { \ - PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\ - exit(1); }) + CHECK_MALLOC_TOO_LATE_FOR_( \ + if (newval) { \ + PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\ + exit(1); }) # define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \ - if (doing_taint(argc,argv,env)) { \ - MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \ + if (doing_taint(argc,argv,env)) { \ + MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \ }} STMT_END; #else /* MYMALLOC */ # define safemalloc safesysmalloc @@ -1551,10 +1551,10 @@ was saved by C or C. #ifdef VMS # define SETERRNO(errcode,vmserrcode) \ - STMT_START { \ - set_errno(errcode); \ - set_vaxc_errno(vmserrcode); \ - } STMT_END + STMT_START { \ + set_errno(errcode); \ + set_vaxc_errno(vmserrcode); \ + } STMT_END # define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno # define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno # define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno ) @@ -1647,15 +1647,15 @@ any magic. if (!*svp) { \ *svp = newSVpvs(""); \ } else if (SvREADONLY(*svp)) { \ - SvREFCNT_dec_NN(*svp); \ - *svp = newSVpvs(""); \ + SvREFCNT_dec_NN(*svp); \ + *svp = newSVpvs(""); \ } else { \ - SV *const errsv = *svp; \ + SV *const errsv = *svp; \ SvPVCLEAR(errsv); \ - SvPOK_only(errsv); \ - if (SvMAGICAL(errsv)) { \ - mg_free(errsv); \ - } \ + SvPOK_only(errsv); \ + if (SvMAGICAL(errsv)) { \ + mg_free(errsv); \ + } \ } \ } STMT_END @@ -1666,13 +1666,13 @@ any magic. *svp = newSVpvs(""); \ } else if (SvREADONLY(*svp)) { \ SV *dupsv = newSVsv(*svp); \ - SvREFCNT_dec_NN(*svp); \ - *svp = dupsv; \ + SvREFCNT_dec_NN(*svp); \ + *svp = dupsv; \ } else { \ - SV *const errsv = *svp; \ - if (SvMAGICAL(errsv)) { \ - mg_free(errsv); \ - } \ + SV *const errsv = *svp; \ + if (SvMAGICAL(errsv)) { \ + mg_free(errsv); \ + } \ } \ } STMT_END @@ -1683,10 +1683,10 @@ any magic. (SvREFCNT_dec(GvSV(PL_defgv)), GvSV(PL_defgv) = SvREFCNT_inc(sv)) # define SAVE_DEFSV \ ( \ - save_gp(PL_defgv, 0), \ - GvINTRO_off(PL_defgv), \ - SAVEGENERICSV(GvSV(PL_defgv)), \ - GvSV(PL_defgv) = NULL \ + save_gp(PL_defgv, 0), \ + GvINTRO_off(PL_defgv), \ + SAVEGENERICSV(GvSV(PL_defgv)), \ + GvSV(PL_defgv) = NULL \ ) #else # define DEFSV GvSVn(PL_defgv) @@ -1709,11 +1709,11 @@ Localize C<$_>. See L. */ #ifndef errno - extern int errno; /* ANSI allows errno to be an lvalue expr. - * For example in multithreaded environments - * something like this might happen: - * extern int *_errno(void); - * #define errno (*_errno()) */ + extern int errno; /* ANSI allows errno to be an lvalue expr. + * For example in multithreaded environments + * something like this might happen: + * extern int *_errno(void); + * #define errno (*_errno()) */ #endif #define UNKNOWN_ERRNO_MSG "(unknown)" @@ -3417,8 +3417,8 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # define STATUS_EXIT \ - (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \ - (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0)) + (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \ + (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0)) /* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child @@ -3443,25 +3443,25 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # define STATUS_NATIVE_CHILD_SET(n) \ - STMT_START { \ - I32 evalue = (I32)n; \ - if (evalue == EVMSERR) { \ - PL_statusvalue_vms = vaxc$errno; \ - PL_statusvalue = evalue; \ - } else { \ - PL_statusvalue_vms = evalue; \ - if (evalue == -1) { \ - PL_statusvalue = -1; \ - PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \ - } else \ - PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \ - set_vaxc_errno(evalue); \ - if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \ - set_errno(EVMSERR); \ - else set_errno(Perl_vms_status_to_unix(evalue, 0)); \ - PL_statusvalue = PL_statusvalue << child_offset_bits; \ - } \ - } STMT_END + STMT_START { \ + I32 evalue = (I32)n; \ + if (evalue == EVMSERR) { \ + PL_statusvalue_vms = vaxc$errno; \ + PL_statusvalue = evalue; \ + } else { \ + PL_statusvalue_vms = evalue; \ + if (evalue == -1) { \ + PL_statusvalue = -1; \ + PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \ + } else \ + PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \ + set_vaxc_errno(evalue); \ + if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \ + set_errno(EVMSERR); \ + else set_errno(Perl_vms_status_to_unix(evalue, 0)); \ + PL_statusvalue = PL_statusvalue << child_offset_bits; \ + } \ + } STMT_END # ifdef VMSISH_STATUS # define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX) @@ -3476,23 +3476,23 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) * This is used when Perl is forcing errno to have a specific value. */ # define STATUS_UNIX_SET(n) \ - STMT_START { \ - I32 evalue = (I32)n; \ - PL_statusvalue = evalue; \ - if (PL_statusvalue != -1) { \ - if (PL_statusvalue != EVMSERR) { \ - PL_statusvalue &= 0xFFFF; \ - if (MY_POSIX_EXIT) \ - PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\ - else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \ - } \ - else { \ - PL_statusvalue_vms = vaxc$errno; \ - } \ - } \ - else PL_statusvalue_vms = SS$_ABORT; \ - set_vaxc_errno(PL_statusvalue_vms); \ - } STMT_END + STMT_START { \ + I32 evalue = (I32)n; \ + PL_statusvalue = evalue; \ + if (PL_statusvalue != -1) { \ + if (PL_statusvalue != EVMSERR) { \ + PL_statusvalue &= 0xFFFF; \ + if (MY_POSIX_EXIT) \ + PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\ + else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \ + } \ + else { \ + PL_statusvalue_vms = vaxc$errno; \ + } \ + } \ + else PL_statusvalue_vms = SS$_ABORT; \ + set_vaxc_errno(PL_statusvalue_vms); \ + } STMT_END /* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets * the NATIVE error status based on it. @@ -3510,32 +3510,32 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # define STATUS_UNIX_EXIT_SET(n) \ - STMT_START { \ - I32 evalue = (I32)n; \ - PL_statusvalue = evalue; \ - if (MY_POSIX_EXIT) { \ - if (evalue <= 0xFF00) { \ - if (evalue > 0xFF) \ - evalue = (evalue >> child_offset_bits) & 0xFF; \ - PL_statusvalue_vms = \ - (C_FAC_POSIX | (evalue << 3 ) | \ - ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ - } else /* forgive them Perl, for they have sinned */ \ - PL_statusvalue_vms = evalue; \ - } else { \ - if (evalue == 0) \ - PL_statusvalue_vms = SS$_NORMAL; \ - else if (evalue <= 0xFF00) \ - PL_statusvalue_vms = SS$_ABORT; \ - else { /* forgive them Perl, for they have sinned */ \ - if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ - else PL_statusvalue_vms = vaxc$errno; \ - /* And obviously used a VMS status value instead of UNIX */ \ - PL_statusvalue = EVMSERR; \ - } \ - set_vaxc_errno(PL_statusvalue_vms); \ - } \ - } STMT_END + STMT_START { \ + I32 evalue = (I32)n; \ + PL_statusvalue = evalue; \ + if (MY_POSIX_EXIT) { \ + if (evalue <= 0xFF00) { \ + if (evalue > 0xFF) \ + evalue = (evalue >> child_offset_bits) & 0xFF; \ + PL_statusvalue_vms = \ + (C_FAC_POSIX | (evalue << 3 ) | \ + ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ + } else /* forgive them Perl, for they have sinned */ \ + PL_statusvalue_vms = evalue; \ + } else { \ + if (evalue == 0) \ + PL_statusvalue_vms = SS$_NORMAL; \ + else if (evalue <= 0xFF00) \ + PL_statusvalue_vms = SS$_ABORT; \ + else { /* forgive them Perl, for they have sinned */ \ + if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ + else PL_statusvalue_vms = vaxc$errno; \ + /* And obviously used a VMS status value instead of UNIX */ \ + PL_statusvalue = EVMSERR; \ + } \ + set_vaxc_errno(PL_statusvalue_vms); \ + } \ + } STMT_END /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code @@ -3556,28 +3556,28 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) */ # define STATUS_EXIT_SET(n) \ - STMT_START { \ - I32 evalue = (I32)n; \ - PL_statusvalue = evalue; \ - if (MY_POSIX_EXIT) \ - if (evalue > 255) PL_statusvalue_vms = evalue; else { \ - PL_statusvalue_vms = \ - (C_FAC_POSIX | (evalue << 3 ) | \ - ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \ - else \ - PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \ - set_vaxc_errno(PL_statusvalue_vms); \ - } STMT_END + STMT_START { \ + I32 evalue = (I32)n; \ + PL_statusvalue = evalue; \ + if (MY_POSIX_EXIT) \ + if (evalue > 255) PL_statusvalue_vms = evalue; else { \ + PL_statusvalue_vms = \ + (C_FAC_POSIX | (evalue << 3 ) | \ + ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \ + else \ + PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \ + set_vaxc_errno(PL_statusvalue_vms); \ + } STMT_END /* This macro forces a success status */ # define STATUS_ALL_SUCCESS \ - (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL) + (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL) /* This macro forces a failure status */ # define STATUS_ALL_FAILURE (PL_statusvalue = 1, \ vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \ - (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT) + (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT) #elif defined(__amigaos4__) /* A somewhat experimental attempt to simulate posix return code values */ @@ -3593,11 +3593,11 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) } \ } STMT_END # define STATUS_UNIX_SET(n) \ - STMT_START { \ - PL_statusvalue = (n); \ - if (PL_statusvalue != -1) \ - PL_statusvalue &= 0xFFFF; \ - } STMT_END + STMT_START { \ + PL_statusvalue = (n); \ + if (PL_statusvalue != -1) \ + PL_statusvalue &= 0xFFFF; \ + } STMT_END # define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_CURRENT STATUS_UNIX @@ -3645,11 +3645,11 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) } STMT_END # endif # define STATUS_UNIX_SET(n) \ - STMT_START { \ - PL_statusvalue = (n); \ - if (PL_statusvalue != -1) \ - PL_statusvalue &= 0xFFFF; \ - } STMT_END + STMT_START { \ + PL_statusvalue = (n); \ + if (PL_statusvalue != -1) \ + PL_statusvalue &= 0xFFFF; \ + } STMT_END # define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n) # define STATUS_CURRENT STATUS_UNIX @@ -3926,13 +3926,13 @@ intrinsic function, see its documents for more details. #ifndef IOCPARM_LEN # ifdef IOCPARM_MASK - /* on BSDish systems we're safe */ + /* on BSDish systems we're safe */ # define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) # elif defined(_IOC_SIZE) && defined(__GLIBC__) - /* on Linux systems we're safe; except when we're not [perl #38223] */ + /* on Linux systems we're safe; except when we're not [perl #38223] */ # define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x)) # else - /* otherwise guess at what's safe */ + /* otherwise guess at what's safe */ # define IOCPARM_LEN(x) 256 # endif #endif @@ -3982,13 +3982,13 @@ typedef I32 (*filter_t) (pTHX_ int, SV *, int); #define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) #define FILTER_DATA(idx) \ - (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL) + (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL) #define FILTER_ISREADER(idx) \ - (PL_parser && PL_parser->rsfp_filters \ - && idx >= AvFILLp(PL_parser->rsfp_filters)) + (PL_parser && PL_parser->rsfp_filters \ + && idx >= AvFILLp(PL_parser->rsfp_filters)) #define PERL_FILTER_EXISTS(i) \ - (PL_parser && PL_parser->rsfp_filters \ - && (Size_t) (i) < av_count(PL_parser->rsfp_filters)) + (PL_parser && PL_parser->rsfp_filters \ + && (Size_t) (i) < av_count(PL_parser->rsfp_filters)) #if defined(_AIX) && !defined(_AIX43) #if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE) @@ -4192,7 +4192,7 @@ my_swap16(const U16 x) { the error message. Please check the value of the macro BYTEORDER, as defined in config.h. The values of BYTEORDER we expect are - big endian little endian + big endian little endian 32 bit 0x4321 0x1234 64 bit 0x87654321 0x12345678 @@ -4216,9 +4216,9 @@ my_swap16(const U16 x) { # define htovs(x) vtohs(x) #elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 # define vtohl(x) ((((x)&0xFF)<<24) \ - +(((x)>>24)&0xFF) \ - +(((x)&0x0000FF00)<<8) \ - +(((x)&0x00FF0000)>>8) ) + +(((x)>>24)&0xFF) \ + +(((x)&0x0000FF00)<<8) \ + +(((x)&0x00FF0000)>>8) ) # define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) # define htovl(x) vtohl(x) # define htovs(x) vtohs(x) @@ -4321,7 +4321,7 @@ equal zero. #define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX) /* Used with UV/IV arguments: */ - /* XXXX: need to speed it up */ + /* XXXX: need to speed it up */ #define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv)) #define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv)) @@ -4344,11 +4344,11 @@ Gid_t getegid (void); #ifndef Perl_error_log # define Perl_error_log (PL_stderrgv \ - && isGV(PL_stderrgv) \ - && GvIOp(PL_stderrgv) \ - && IoOFP(GvIOp(PL_stderrgv)) \ - ? IoOFP(GvIOp(PL_stderrgv)) \ - : PerlIO_stderr()) + && isGV(PL_stderrgv) \ + && GvIOp(PL_stderrgv) \ + && IoOFP(GvIOp(PL_stderrgv)) \ + ? IoOFP(GvIOp(PL_stderrgv)) \ + : PerlIO_stderr()) #endif @@ -4633,16 +4633,16 @@ Gid_t getegid (void); #define DEBUG_SCOPE(where) \ DEBUG_l( \ Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \ - where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \ - __FILE__, __LINE__)); + where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \ + __FILE__, __LINE__)); /* Keep the old croak based assert for those who want it, and as a fallback if the platform is so heretically non-ANSI that it can't assert. */ #define Perl_assert(what) PERL_DEB2( \ - ((what) ? ((void) 0) : \ - (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ - "\", line %d", STRINGIFY(what), __LINE__), \ + ((what) ? ((void) 0) : \ + (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ + "\", line %d", STRINGIFY(what), __LINE__), \ (void) 0)), ((void)0)) /* assert() gets defined if DEBUGGING. @@ -4760,10 +4760,10 @@ EXTERN_C void PerlIO_teardown(void); # ifdef USE_ITHREADS # define PERLIO_INIT MUTEX_INIT(&PL_perlio_mutex) # define PERLIO_TERM \ - STMT_START { \ - PerlIO_teardown(); \ - MUTEX_DESTROY(&PL_perlio_mutex);\ - } STMT_END + STMT_START { \ + PerlIO_teardown(); \ + MUTEX_DESTROY(&PL_perlio_mutex);\ + } STMT_END # else # define PERLIO_INIT # define PERLIO_TERM PerlIO_teardown() @@ -4776,16 +4776,16 @@ EXTERN_C void PerlIO_teardown(void); #ifdef MYMALLOC # ifdef MUTEX_INIT_CALLS_MALLOC # define MALLOC_INIT \ - STMT_START { \ - PL_malloc_mutex = NULL; \ - MUTEX_INIT(&PL_malloc_mutex); \ - } STMT_END + STMT_START { \ + PL_malloc_mutex = NULL; \ + MUTEX_INIT(&PL_malloc_mutex); \ + } STMT_END # define MALLOC_TERM \ - STMT_START { \ - perl_mutex tmp = PL_malloc_mutex; \ - PL_malloc_mutex = NULL; \ - MUTEX_DESTROY(&tmp); \ - } STMT_END + STMT_START { \ + perl_mutex tmp = PL_malloc_mutex; \ + PL_malloc_mutex = NULL; \ + MUTEX_DESTROY(&tmp); \ + } STMT_END # else # define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex) # define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex) @@ -4823,8 +4823,8 @@ struct perl_memory_debug_header { # define PERL_MEMORY_DEBUG_HEADER_SIZE \ (sizeof(struct perl_memory_debug_header) + \ - (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ - %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) + (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ + %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) #else # define PERL_MEMORY_DEBUG_HEADER_SIZE 0 @@ -4833,17 +4833,17 @@ struct perl_memory_debug_header { #ifdef PERL_TRACK_MEMPOOL # ifdef PERL_DEBUG_READONLY_COW # define INIT_TRACK_MEMPOOL(header, interp) \ - STMT_START { \ - (header).interpreter = (interp); \ - (header).prev = (header).next = &(header); \ - (header).readonly = 0; \ - } STMT_END + STMT_START { \ + (header).interpreter = (interp); \ + (header).prev = (header).next = &(header); \ + (header).readonly = 0; \ + } STMT_END # else # define INIT_TRACK_MEMPOOL(header, interp) \ - STMT_START { \ - (header).interpreter = (interp); \ - (header).prev = (header).next = &(header); \ - } STMT_END + STMT_START { \ + (header).interpreter = (interp); \ + (header).prev = (header).next = &(header); \ + } STMT_END # endif # else # define INIT_TRACK_MEMPOOL(header, interp) @@ -4860,7 +4860,7 @@ struct perl_memory_debug_header { # if defined(HAS_MALLOC_SIZE) && !defined(PERL_DEBUG_READONLY_COW) # ifdef PERL_TRACK_MEMPOOL # define Perl_safesysmalloc_size(where) \ - (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) + (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) # else # define Perl_safesysmalloc_size(where) malloc_size(where) # endif @@ -4868,7 +4868,7 @@ struct perl_memory_debug_header { # ifdef HAS_MALLOC_GOOD_SIZE # ifdef PERL_TRACK_MEMPOOL # define Perl_malloc_good_size(how_much) \ - (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) + (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) # else # define Perl_malloc_good_size(how_much) malloc_good_size(how_much) # endif @@ -4898,12 +4898,12 @@ EXTERN_C char **environ; /* environment variables supplied via exec */ #undef PERL_PATCHLEVEL_H_IMPLICIT #define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \ - STRINGIFY(PERL_VERSION) "." \ - STRINGIFY(PERL_SUBVERSION) + STRINGIFY(PERL_VERSION) "." \ + STRINGIFY(PERL_SUBVERSION) #define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \ - STRINGIFY(PERL_API_VERSION) "." \ - STRINGIFY(PERL_API_SUBVERSION) + STRINGIFY(PERL_API_VERSION) "." \ + STRINGIFY(PERL_API_SUBVERSION) START_EXTERN_C @@ -5051,73 +5051,73 @@ EXTCONST int PL_sig_num[]; * ebcdic_tables.h */ EXTCONST unsigned char PL_fold[] = { - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', - 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', - 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', - 'x', 'y', 'z', 91, 92, 93, 94, 95, - 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', 123, 124, 125, 126, 127, - 128, 129, 130, 131, 132, 133, 134, 135, - 136, 137, 138, 139, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, - 152, 153, 154, 155, 156, 157, 158, 159, - 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, - 176, 177, 178, 179, 180, 181, 182, 183, - 184, 185, 186, 187, 188, 189, 190, 191, - 192, 193, 194, 195, 196, 197, 198, 199, - 200, 201, 202, 203, 204, 205, 206, 207, - 208, 209, 210, 211, 212, 213, 214, 215, - 216, 217, 218, 219, 220, 221, 222, 223, - 224, 225, 226, 227, 228, 229, 230, 231, - 232, 233, 234, 235, 236, 237, 238, 239, - 240, 241, 242, 243, 244, 245, 246, 247, - 248, 249, 250, 251, 252, 253, 254, 255 + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 }; EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */ - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', - 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', - 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', - 'x', 'y', 'z', 91, 92, 93, 94, 95, - 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', 123, 124, 125, 126, 127, - 128, 129, 130, 131, 132, 133, 134, 135, - 136, 137, 138, 139, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, - 152, 153, 154, 155, 156, 157, 158, 159, - 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, - 176, 177, 178, 179, 180, 181, 182, 183, - 184, 185, 186, 187, 188, 189, 190, 191, - 192, 193, 194, 195, 196, 197, 198, 199, - 200, 201, 202, 203, 204, 205, 206, 207, - 208, 209, 210, 211, 212, 213, 214, 215, - 216, 217, 218, 219, 220, 221, 222, 223, - 224, 225, 226, 227, 228, 229, 230, 231, - 232, 233, 234, 235, 236, 237, 238, 239, - 240, 241, 242, 243, 244, 245, 246, 247, - 248, 249, 250, 251, 252, 253, 254, 255 + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 }; EXTCONST unsigned char PL_fold_latin1[] = { @@ -5129,120 +5129,120 @@ EXTCONST unsigned char PL_fold_latin1[] = { * not one, so can't be represented in this table. * * All have to be specially handled */ - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', - 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', - 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', - 'x', 'y', 'z', 91, 92, 93, 94, 95, - 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', 123, 124, 125, 126, 127, - 128, 129, 130, 131, 132, 133, 134, 135, - 136, 137, 138, 139, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, - 152, 153, 154, 155, 156, 157, 158, 159, - 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, - 176, 177, 178, 179, 180, 181 /*micro */, 182, 183, - 184, 185, 186, 187, 188, 189, 190, 191, - 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, - 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, - 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, - 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223 /* ss */, - 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, - 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, - 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, - 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, - 255 /* y with diaeresis */ + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181 /*micro */, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, + 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, + 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, + 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223 /* ss */, + 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, + 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, + 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, + 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, + 255 /* y with diaeresis */ }; /* If these tables are accessed through ebcdic, the access will be converted to * latin1 first */ EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */ - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', - 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', - 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', - 'x', 'y', 'z', 91, 92, 93, 94, 95, - 96, 97, 98, 99, 100, 101, 102, 103, - 104, 105, 106, 107, 108, 109, 110, 111, - 112, 113, 114, 115, 116, 117, 118, 119, - 120, 121, 122, 123, 124, 125, 126, 127, - 128, 129, 130, 131, 132, 133, 134, 135, - 136, 137, 138, 139, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, - 152, 153, 154, 155, 156, 157, 158, 159, - 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, - 176, 177, 178, 179, 180, 181, 182, 183, - 184, 185, 186, 187, 188, 189, 190, 191, - 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, - 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, - 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, - 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, - 224, 225, 226, 227, 228, 229, 230, 231, - 232, 233, 234, 235, 236, 237, 238, 239, - 240, 241, 242, 243, 244, 245, 246, 247, - 248, 249, 250, 251, 252, 253, 254, 255 + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, + 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, + 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, + 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, + 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 }; /* upper and title case of latin1 characters, modified so that the three tricky * ones are mapped to 255 (which is one of the three) */ EXTCONST unsigned char PL_mod_latin1_uc[] = { - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 65, 66, 67, 68, 69, 70, 71, - 72, 73, 74, 75, 76, 77, 78, 79, - 80, 81, 82, 83, 84, 85, 86, 87, - 88, 89, 90, 91, 92, 93, 94, 95, - 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', 123, 124, 125, 126, 127, - 128, 129, 130, 131, 132, 133, 134, 135, - 136, 137, 138, 139, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, - 152, 153, 154, 155, 156, 157, 158, 159, - 160, 161, 162, 163, 164, 165, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 175, - 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, - 184, 185, 186, 187, 188, 189, 190, 191, - 192, 193, 194, 195, 196, 197, 198, 199, - 200, 201, 202, 203, 204, 205, 206, 207, - 208, 209, 210, 211, 212, 213, 214, 215, - 216, 217, 218, 219, 220, 221, 222, + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, + 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, + 88, 89, 90, 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, # if UNICODE_MAJOR_VERSION > 2 \ || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ && UNICODE_DOT_DOT_VERSION >= 8) - 255 /*sharp s*/, + 255 /*sharp s*/, # else /* uc(sharp s) is 'sharp s' itself in early unicode */ - 223, + 223, # endif - 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, - 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, - 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, - 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 + 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, + 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, + 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, + 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 }; # endif /* !EBCDIC, but still in DOINIT */ #else /* ! DOINIT */ @@ -5260,19 +5260,19 @@ EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */ * which has DEBUGGING enabled always */ #ifdef DOINIT EXTCONST char* const PL_block_type[] = { - "NULL", - "WHEN", - "BLOCK", - "GIVEN", - "LOOP_ARY", - "LOOP_LAZYSV", - "LOOP_LAZYIV", - "LOOP_LIST", - "LOOP_PLAIN", - "SUB", - "FORMAT", - "EVAL", - "SUBST" + "NULL", + "WHEN", + "BLOCK", + "GIVEN", + "LOOP_ARY", + "LOOP_LAZYSV", + "LOOP_LAZYIV", + "LOOP_LIST", + "LOOP_PLAIN", + "SUB", + "FORMAT", + "EVAL", + "SUBST" }; #else EXTCONST char* PL_block_type[]; @@ -5286,100 +5286,100 @@ EXTCONST char* PL_block_type[]; #ifdef DOINIT EXTCONST char PL_bincompat_options[] = # ifdef DEBUG_LEAKING_SCALARS - " DEBUG_LEAKING_SCALARS" + " DEBUG_LEAKING_SCALARS" # endif # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - " DEBUG_LEAKING_SCALARS_FORK_DUMP" + " DEBUG_LEAKING_SCALARS_FORK_DUMP" # endif # ifdef HAS_TIMES - " HAS_TIMES" + " HAS_TIMES" # endif # ifdef HAVE_INTERP_INTERN - " HAVE_INTERP_INTERN" + " HAVE_INTERP_INTERN" # endif # ifdef MULTIPLICITY - " MULTIPLICITY" + " MULTIPLICITY" # endif # ifdef MYMALLOC - " MYMALLOC" + " MYMALLOC" # endif # ifdef PERLIO_LAYERS - " PERLIO_LAYERS" + " PERLIO_LAYERS" # endif # ifdef PERL_DEBUG_READONLY_COW - " PERL_DEBUG_READONLY_COW" + " PERL_DEBUG_READONLY_COW" # endif # ifdef PERL_DEBUG_READONLY_OPS - " PERL_DEBUG_READONLY_OPS" + " PERL_DEBUG_READONLY_OPS" # endif # ifdef PERL_IMPLICIT_CONTEXT - " PERL_IMPLICIT_CONTEXT" + " PERL_IMPLICIT_CONTEXT" # endif # ifdef PERL_IMPLICIT_SYS - " PERL_IMPLICIT_SYS" + " PERL_IMPLICIT_SYS" # endif # ifdef PERL_MICRO - " PERL_MICRO" + " PERL_MICRO" # endif # ifdef PERL_POISON - " PERL_POISON" + " PERL_POISON" # endif # ifdef PERL_SAWAMPERSAND - " PERL_SAWAMPERSAND" + " PERL_SAWAMPERSAND" # endif # ifdef PERL_TRACK_MEMPOOL - " PERL_TRACK_MEMPOOL" + " PERL_TRACK_MEMPOOL" # endif # ifdef PERL_USES_PL_PIDSTATUS - " PERL_USES_PL_PIDSTATUS" + " PERL_USES_PL_PIDSTATUS" # endif # ifdef USE_64_BIT_ALL - " USE_64_BIT_ALL" + " USE_64_BIT_ALL" # endif # ifdef USE_64_BIT_INT - " USE_64_BIT_INT" + " USE_64_BIT_INT" # endif # ifdef USE_IEEE - " USE_IEEE" + " USE_IEEE" # endif # ifdef USE_ITHREADS - " USE_ITHREADS" + " USE_ITHREADS" # endif # ifdef USE_LARGE_FILES - " USE_LARGE_FILES" + " USE_LARGE_FILES" # endif # ifdef USE_LOCALE_COLLATE - " USE_LOCALE_COLLATE" + " USE_LOCALE_COLLATE" # endif # ifdef USE_LOCALE_NUMERIC - " USE_LOCALE_NUMERIC" + " USE_LOCALE_NUMERIC" # endif # ifdef USE_LOCALE_TIME - " USE_LOCALE_TIME" + " USE_LOCALE_TIME" # endif # ifdef USE_LONG_DOUBLE - " USE_LONG_DOUBLE" + " USE_LONG_DOUBLE" # endif # ifdef USE_PERLIO - " USE_PERLIO" + " USE_PERLIO" # endif # ifdef USE_QUADMATH - " USE_QUADMATH" + " USE_QUADMATH" # endif # ifdef USE_REENTRANT_API - " USE_REENTRANT_API" + " USE_REENTRANT_API" # endif # ifdef USE_SOCKS - " USE_SOCKS" + " USE_SOCKS" # endif # ifdef VMS_DO_SOCKETS - " VMS_DO_SOCKETS" + " VMS_DO_SOCKETS" # endif # ifdef VMS_SHORTEN_LONG_SYMBOLS - " VMS_SHORTEN_LONG_SYMBOLS" + " VMS_SHORTEN_LONG_SYMBOLS" # endif # ifdef VMS_WE_ARE_CASE_SENSITIVE - " VMS_SYMBOL_CASE_AS_IS" + " VMS_SYMBOL_CASE_AS_IS" # endif ""; #else @@ -5516,11 +5516,11 @@ typedef enum { #define HINT_FEATURE_MASK 0x3c000000 /* 4 bits for feature bundles */ - /* Note: Used for HINT_M_VMSISH_*, - currently defined by vms/vmsish.h: - 0x40000000 - 0x80000000 - */ + /* Note: Used for HINT_M_VMSISH_*, + currently defined by vms/vmsish.h: + 0x40000000 + 0x80000000 + */ /* The following are stored in $^H{sort}, not in PL_hints */ #define HINT_SORT_STABLE 0x00000100 /* sort styles */ @@ -5544,7 +5544,7 @@ typedef enum { #ifndef PERL_SAWAMPERSAND # define PL_sawampersand \ - (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT) + (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT) #endif /* Used for debugvar magic */ @@ -5573,19 +5573,19 @@ struct perl_debug_pad { #define PERL_DEBUG_PAD(i) &(PL_debug_pad.pad[i]) #define PERL_DEBUG_PAD_ZERO(i) (SvPVX(PERL_DEBUG_PAD(i))[0] = 0, \ - (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \ - PERL_DEBUG_PAD(i)) + (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \ + PERL_DEBUG_PAD(i)) /* Enable variables which are pointers to functions */ typedef void (*peep_t)(pTHX_ OP* o); typedef regexp* (*regcomp_t) (pTHX_ char* exp, char* xend, PMOP* pm); typedef I32 (*regexec_t) (pTHX_ regexp* prog, char* stringarg, - char* strend, char* strbeg, I32 minend, - SV* screamer, void* data, U32 flags); + char* strend, char* strbeg, I32 minend, + SV* screamer, void* data, U32 flags); typedef char* (*re_intuit_start_t) (pTHX_ regexp *prog, SV *sv, - char *strpos, char *strend, - U32 flags, - re_scream_pos_data *d); + char *strpos, char *strend, + U32 flags, + re_scream_pos_data *d); typedef SV* (*re_intuit_string_t) (pTHX_ regexp *prog); typedef void (*regfree_t) (pTHX_ struct regexp* r); typedef regexp* (*regdupe_t) (pTHX_ const regexp* r, CLONE_PARAMS *param); @@ -5815,7 +5815,7 @@ EXTCONST U8 PL_magic_data[256]; #endif #ifdef DOINIT - /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO */ + /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO */ EXTCONST bool PL_valid_types_IVX[] = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 }; EXTCONST bool @@ -6352,16 +6352,16 @@ typedef struct am_table_short AMTS; #endif /* _FASTMATH */ #define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ - PERLDBf_NOOPT | PERLDBf_INTER | \ - PERLDBf_SUBLINE| PERLDBf_SINGLE| \ - PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \ - PERLDBf_SAVESRC) - /* No _NONAME, _GOTO */ + PERLDBf_NOOPT | PERLDBf_INTER | \ + PERLDBf_SUBLINE| PERLDBf_SINGLE| \ + PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \ + PERLDBf_SAVESRC) + /* No _NONAME, _GOTO */ #define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ #define PERLDBf_LINE 0x02 /* Keep line # */ #define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ #define PERLDBf_INTER 0x08 /* Preserve more data for - later inspections */ + later inspections */ #define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */ #define PERLDBf_SINGLE 0x20 /* Start with single-step on */ #define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */ @@ -6492,7 +6492,7 @@ the plain locale pragma without a parameter (S>) is in effect. * argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded * string, and an end position which it won't try to read past */ # define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp) \ - STMT_START { \ + STMT_START { \ if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \ Perl_warner(aTHX_ packWARN(WARN_LOCALE), \ "Wide character (U+%" UVXf ") in %s",\ @@ -6501,7 +6501,7 @@ the plain locale pragma without a parameter (S>) is in effect. } STMT_END # define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \ - STMT_START { /* Check if to warn before doing the conversion work */\ + STMT_START { /* Check if to warn before doing the conversion work */\ if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \ UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \ Perl_warner(aTHX_ packWARN(WARN_LOCALE), \ @@ -6959,7 +6959,7 @@ cannot have changed since the precalculation. /* The next two macros set unconditionally. These should be rarely used, and * only after being sure that this is what is needed */ # define SET_NUMERIC_STANDARD() \ - STMT_START { \ + STMT_START { \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ "%s: %d: lc_numeric standard=%d\n", \ __FILE__, __LINE__, PL_numeric_standard)); \ @@ -6970,7 +6970,7 @@ cannot have changed since the precalculation. } STMT_END # define SET_NUMERIC_UNDERLYING() \ - STMT_START { \ + STMT_START { \ if (_NOT_IN_NUMERIC_UNDERLYING) { \ Perl_set_numeric_underlying(aTHX); \ } \ @@ -6990,7 +6990,7 @@ cannot have changed since the precalculation. /* Rarely, we want to change to the underlying locale even outside of 'use * locale'. This is principally in the POSIX:: functions */ # define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \ - STMT_START { \ + STMT_START { \ LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_UNDERLYING); \ if (_NOT_IN_NUMERIC_UNDERLYING) { \ Perl_set_numeric_underlying(aTHX); \ @@ -7165,7 +7165,7 @@ C. #endif #if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \ - (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) + (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) # ifdef __hpux # define strtoll __strtoll /* secret handshake */ # endif @@ -7188,7 +7188,7 @@ C. * (as is done for Atoul(), see below) but for backward compatibility * we just assume atol(). */ # if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && defined(HAS_ATOLL) && \ - (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) + (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) # ifdef WIN64 # define atoll _atoi64 /* secret handshake */ # endif @@ -7199,7 +7199,7 @@ C. #endif #if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && \ - (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) + (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) # ifdef __hpux # define strtoull __strtoull /* secret handshake */ # endif @@ -7271,19 +7271,19 @@ C. # include # ifndef HAS_UNION_SEMUN /* Provide the union semun. */ union semun { - int val; - struct semid_ds *buf; - unsigned short *array; + int val; + struct semid_ds *buf; + unsigned short *array; }; # endif # ifdef USE_SEMCTL_SEMUN # ifdef IRIX32_SEMUN_BROKEN_BY_GCC union gccbug_semun { - int val; - struct semid_ds *buf; - unsigned short *array; - char __dummy[5]; - }; + int val; + struct semid_ds *buf; + unsigned short *array; + char __dummy[5]; + }; # define semun gccbug_semun # endif # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun) @@ -7331,27 +7331,27 @@ C. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ # define MY_CXT_INIT \ - my_cxt_t *my_cxtp = \ - (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ - PERL_UNUSED_VAR(my_cxtp) + my_cxt_t *my_cxtp = \ + (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ + PERL_UNUSED_VAR(my_cxtp) # define MY_CXT_INIT_INTERP(my_perl) \ - my_cxt_t *my_cxtp = \ - (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ - PERL_UNUSED_VAR(my_cxtp) + my_cxt_t *my_cxtp = \ + (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ + PERL_UNUSED_VAR(my_cxtp) /* This declaration should be used within all functions that use the * interpreter-local data. */ # define dMY_CXT \ - my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX] + my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX] # define dMY_CXT_INTERP(my_perl) \ - my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX] + my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX] /* Clones the per-interpreter data. */ # define MY_CXT_CLONE \ - my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ - void * old_my_cxtp = PL_my_cxt_list[MY_CXT_INDEX]; \ - PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp; \ - Copy(old_my_cxtp, my_cxtp, 1, my_cxt_t); + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + void * old_my_cxtp = PL_my_cxt_list[MY_CXT_INDEX]; \ + PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp; \ + Copy(old_my_cxtp, my_cxtp, 1, my_cxt_t); @@ -7447,8 +7447,8 @@ EXTERN_C int flock(int fd, int op); #endif #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not - int). value returned in pointed- - to UV */ + int). value returned in pointed- + to UV */ #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */ #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation or infnan */ #define IS_NUMBER_NEG 0x08 /* leading minus sign */ @@ -7540,18 +7540,18 @@ extern void moncontrol(int); #define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100 #define PERL_UNICODE_STD_FLAG \ - (PERL_UNICODE_STDIN_FLAG | \ - PERL_UNICODE_STDOUT_FLAG | \ - PERL_UNICODE_STDERR_FLAG) + (PERL_UNICODE_STDIN_FLAG | \ + PERL_UNICODE_STDOUT_FLAG | \ + PERL_UNICODE_STDERR_FLAG) #define PERL_UNICODE_INOUT_FLAG \ - (PERL_UNICODE_IN_FLAG | \ - PERL_UNICODE_OUT_FLAG) + (PERL_UNICODE_IN_FLAG | \ + PERL_UNICODE_OUT_FLAG) #define PERL_UNICODE_DEFAULT_FLAGS \ - (PERL_UNICODE_STD_FLAG | \ - PERL_UNICODE_INOUT_FLAG | \ - PERL_UNICODE_LOCALE_FLAG) + (PERL_UNICODE_STD_FLAG | \ + PERL_UNICODE_INOUT_FLAG | \ + PERL_UNICODE_LOCALE_FLAG) #define PERL_UNICODE_ALL_FLAGS 0x01ff @@ -7601,7 +7601,7 @@ so no C. #endif #define do_open(g, n, l, a, rm, rp, sf) \ - do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0) + do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0) #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION # define do_exec(cmd) do_exec3(cmd,0,0) #endif diff --git a/pp.c b/pp.c index 68b4e461562d..4a2f67046809 100644 --- a/pp.c +++ b/pp.c @@ -38,7 +38,7 @@ PP(pp_stub) { dSP; if (GIMME_V == G_SCALAR) - XPUSHs(&PL_sv_undef); + XPUSHs(&PL_sv_undef); RETURN; } @@ -65,24 +65,24 @@ PP(pp_clonecv) { dTARGET; CV * const protocv = PadnamePROTOCV( - PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] + PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] ); assert(SvTYPE(TARG) == SVt_PVCV); assert(protocv); if (CvISXSUB(protocv)) { /* constant */ - /* XXX Should we clone it here? */ - /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV - to introcv and remove the SvPADSTALE_off. */ - SAVEPADSVANDMORTALIZE(ARGTARG); - PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); + /* XXX Should we clone it here? */ + /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV + to introcv and remove the SvPADSTALE_off. */ + SAVEPADSVANDMORTALIZE(ARGTARG); + PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); } else { - if (CvROOT(protocv)) { - assert(CvCLONE(protocv)); - assert(!CvCLONED(protocv)); - } - cv_clone_into(protocv,(CV *)TARG); - SAVECLEARSV(PAD_SVl(ARGTARG)); + if (CvROOT(protocv)) { + assert(CvCLONE(protocv)); + assert(!CvCLONED(protocv)); + } + cv_clone_into(protocv,(CV *)TARG); + SAVECLEARSV(PAD_SVl(ARGTARG)); } return NORMAL; } @@ -103,65 +103,65 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, { if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - sv = amagic_deref_call(sv, to_gv_amg); - } + if (SvAMAGIC(sv)) { + sv = amagic_deref_call(sv, to_gv_amg); + } wasref: - sv = SvRV(sv); - if (SvTYPE(sv) == SVt_PVIO) { - GV * const gv = MUTABLE_GV(sv_newmortal()); - gv_init(gv, 0, "__ANONIO__", 10, 0); - GvIOp(gv) = MUTABLE_IO(sv); - SvREFCNT_inc_void_NN(sv); - sv = MUTABLE_SV(gv); - } - else if (!isGV_with_GP(sv)) { - Perl_die(aTHX_ "Not a GLOB reference"); + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVIO) { + GV * const gv = MUTABLE_GV(sv_newmortal()); + gv_init(gv, 0, "__ANONIO__", 10, 0); + GvIOp(gv) = MUTABLE_IO(sv); + SvREFCNT_inc_void_NN(sv); + sv = MUTABLE_SV(gv); + } + else if (!isGV_with_GP(sv)) { + Perl_die(aTHX_ "Not a GLOB reference"); } } else { - if (!isGV_with_GP(sv)) { - if (!SvOK(sv)) { - /* If this is a 'my' scalar and flag is set then vivify - * NI-S 1999/05/07 - */ - if (vivify_sv && sv != &PL_sv_undef) { - GV *gv; - HV *stash; - if (SvREADONLY(sv)) - Perl_croak_no_modify(); - gv = MUTABLE_GV(newSV(0)); - stash = CopSTASH(PL_curcop); - if (SvTYPE(stash) != SVt_PVHV) stash = NULL; - if (cUNOP->op_targ) { - SV * const namesv = PAD_SV(cUNOP->op_targ); - gv_init_sv(gv, stash, namesv, 0); - } - else { - gv_init_pv(gv, stash, "__ANONIO__", 0); - } - prepare_SV_for_RV(sv); - SvRV_set(sv, MUTABLE_SV(gv)); - SvROK_on(sv); - SvSETMAGIC(sv); - goto wasref; - } - if (PL_op->op_flags & OPf_REF || strict) { - Perl_die(aTHX_ PL_no_usym, "a symbol"); + if (!isGV_with_GP(sv)) { + if (!SvOK(sv)) { + /* If this is a 'my' scalar and flag is set then vivify + * NI-S 1999/05/07 + */ + if (vivify_sv && sv != &PL_sv_undef) { + GV *gv; + HV *stash; + if (SvREADONLY(sv)) + Perl_croak_no_modify(); + gv = MUTABLE_GV(newSV(0)); + stash = CopSTASH(PL_curcop); + if (SvTYPE(stash) != SVt_PVHV) stash = NULL; + if (cUNOP->op_targ) { + SV * const namesv = PAD_SV(cUNOP->op_targ); + gv_init_sv(gv, stash, namesv, 0); + } + else { + gv_init_pv(gv, stash, "__ANONIO__", 0); + } + prepare_SV_for_RV(sv); + SvRV_set(sv, MUTABLE_SV(gv)); + SvROK_on(sv); + SvSETMAGIC(sv); + goto wasref; } - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return &PL_sv_undef; - } - if (noinit) - { - if (!(sv = MUTABLE_SV(gv_fetchsv_nomg( - sv, GV_ADDMG, SVt_PVGV - )))) - return &PL_sv_undef; - } - else { - if (strict) { + if (PL_op->op_flags & OPf_REF || strict) { + Perl_die(aTHX_ PL_no_usym, "a symbol"); + } + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return &PL_sv_undef; + } + if (noinit) + { + if (!(sv = MUTABLE_SV(gv_fetchsv_nomg( + sv, GV_ADDMG, SVt_PVGV + )))) + return &PL_sv_undef; + } + else { + if (strict) { Perl_die(aTHX_ PL_no_symref_sv, sv, @@ -169,24 +169,24 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, "a symbol" ); } - if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) - == OPpDONT_INIT_GV) { - /* We are the target of a coderef assignment. Return - the scalar unchanged, and let pp_sasssign deal with - things. */ - return sv; - } - sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV)); - } - /* FAKE globs in the symbol table cause weird bugs (#77810) */ - SvFAKE_off(sv); - } + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) + == OPpDONT_INIT_GV) { + /* We are the target of a coderef assignment. Return + the scalar unchanged, and let pp_sasssign deal with + things. */ + return sv; + } + sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV)); + } + /* FAKE globs in the symbol table cause weird bugs (#77810) */ + SvFAKE_off(sv); + } } if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) { - SV *newsv = sv_newmortal(); - sv_setsv_flags(newsv, sv, 0); - SvFAKE_off(newsv); - sv = newsv; + SV *newsv = sv_newmortal(); + sv_setsv_flags(newsv, sv, 0); + SvFAKE_off(newsv); + sv = newsv; } return sv; } @@ -202,7 +202,7 @@ PP(pp_rv2gv) || PL_op->op_type == OP_READLINE ); if (PL_op->op_private & OPpLVAL_INTRO) - save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); + save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } @@ -210,44 +210,44 @@ PP(pp_rv2gv) /* Helper function for pp_rv2sv and pp_rv2av */ GV * Perl_softref2xv(pTHX_ SV *const sv, const char *const what, - const svtype type, SV ***spp) + const svtype type, SV ***spp) { GV *gv; PERL_ARGS_ASSERT_SOFTREF2XV; if (PL_op->op_private & HINT_STRICT_REFS) { - if (SvOK(sv)) - Perl_die(aTHX_ PL_no_symref_sv, sv, - (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); - else - Perl_die(aTHX_ PL_no_usym, what); + if (SvOK(sv)) + Perl_die(aTHX_ PL_no_symref_sv, sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); + else + Perl_die(aTHX_ PL_no_usym, what); } if (!SvOK(sv)) { - if ( - PL_op->op_flags & OPf_REF - ) - Perl_die(aTHX_ PL_no_usym, what); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (type != SVt_PV && GIMME_V == G_ARRAY) { - (*spp)--; - return NULL; - } - **spp = &PL_sv_undef; - return NULL; + if ( + PL_op->op_flags & OPf_REF + ) + Perl_die(aTHX_ PL_no_usym, what); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + if (type != SVt_PV && GIMME_V == G_ARRAY) { + (*spp)--; + return NULL; + } + **spp = &PL_sv_undef; + return NULL; } if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type))) - { - **spp = &PL_sv_undef; - return NULL; - } - } + !(PL_op->op_flags & OPf_MOD)) + { + if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type))) + { + **spp = &PL_sv_undef; + return NULL; + } + } else { - gv = gv_fetchsv_nomg(sv, GV_ADD, type); + gv = gv_fetchsv_nomg(sv, GV_ADD, type); } return gv; } @@ -259,35 +259,35 @@ PP(pp_rv2sv) SvGETMAGIC(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - sv = amagic_deref_call(sv, to_sv_amg); - } + if (SvAMAGIC(sv)) { + sv = amagic_deref_call(sv, to_sv_amg); + } - sv = SvRV(sv); - if (SvTYPE(sv) >= SVt_PVAV) - DIE(aTHX_ "Not a SCALAR reference"); + sv = SvRV(sv); + if (SvTYPE(sv) >= SVt_PVAV) + DIE(aTHX_ "Not a SCALAR reference"); } else { - gv = MUTABLE_GV(sv); + gv = MUTABLE_GV(sv); - if (!isGV_with_GP(gv)) { - gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp); - if (!gv) - RETURN; - } - sv = GvSVn(gv); + if (!isGV_with_GP(gv)) { + gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp); + if (!gv) + RETURN; + } + sv = GvSVn(gv); } if (PL_op->op_flags & OPf_MOD) { - if (PL_op->op_private & OPpLVAL_INTRO) { - if (cUNOP->op_first->op_type == OP_NULL) - sv = save_scalar(MUTABLE_GV(TOPs)); - else if (gv) - sv = save_scalar(gv); - else - Perl_croak(aTHX_ "%s", PL_no_localize_ref); - } - else if (PL_op->op_private & OPpDEREF) - sv = vivify_ref(sv, PL_op->op_private & OPpDEREF); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (cUNOP->op_first->op_type == OP_NULL) + sv = save_scalar(MUTABLE_GV(TOPs)); + else if (gv) + sv = save_scalar(gv); + else + Perl_croak(aTHX_ "%s", PL_no_localize_ref); + } + else if (PL_op->op_private & OPpDEREF) + sv = vivify_ref(sv, PL_op->op_private & OPpDEREF); } SPAGAIN; /* in case chasing soft refs reallocated the stack */ SETs(sv); @@ -300,14 +300,14 @@ PP(pp_av2arylen) AV * const av = MUTABLE_AV(TOPs); const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; if (lvalue) { - SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)); - if (!*svp) { - *svp = newSV_type(SVt_PVMG); - sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0); - } - SETs(*svp); + SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)); + if (!*svp) { + *svp = newSV_type(SVt_PVMG); + sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0); + } + SETs(*svp); } else { - SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av))))); + SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av))))); } RETURN; } @@ -317,16 +317,16 @@ PP(pp_pos) dSP; dTOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { - SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ - sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0); - LvTYPE(ret) = '.'; - LvTARG(ret) = SvREFCNT_inc_simple(sv); - SETs(ret); /* no SvSETMAGIC */ + SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0); + LvTYPE(ret) = '.'; + LvTARG(ret) = SvREFCNT_inc_simple(sv); + SETs(ret); /* no SvSETMAGIC */ } else { - const MAGIC * const mg = mg_find_mglob(sv); - if (mg && mg->mg_len != -1) { - STRLEN i = mg->mg_len; + const MAGIC * const mg = mg_find_mglob(sv); + if (mg && mg->mg_len != -1) { + STRLEN i = mg->mg_len; if (PL_op->op_private & OPpTRUEBOOL) SETs(i ? &PL_sv_yes : &PL_sv_zero); else { @@ -335,9 +335,9 @@ PP(pp_pos) i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); SETu(i); } - return NORMAL; - } - SETs(&PL_sv_undef); + return NORMAL; + } + SETs(&PL_sv_undef); } return NORMAL; } @@ -348,23 +348,23 @@ PP(pp_rv2cv) GV *gv; HV *stash_unused; const I32 flags = (PL_op->op_flags & OPf_SPECIAL) - ? GV_ADDMG - : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) + ? GV_ADDMG + : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT) - ? GV_ADD|GV_NOEXPAND - : GV_ADD; + ? GV_ADD|GV_NOEXPAND + : GV_ADD; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); if (cv) NOOP; else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { - cv = SvTYPE(SvRV(gv)) == SVt_PVCV - ? MUTABLE_CV(SvRV(gv)) - : MUTABLE_CV(gv); + cv = SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : MUTABLE_CV(gv); } else - cv = MUTABLE_CV(&PL_sv_undef); + cv = MUTABLE_CV(&PL_sv_undef); SETs(MUTABLE_SV(cv)); return NORMAL; } @@ -379,24 +379,24 @@ PP(pp_prototype) if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs)); if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { - const char * s = SvPVX_const(TOPs); + const char * s = SvPVX_const(TOPs); if (memBEGINs(s, SvCUR(TOPs), "CORE::")) { - const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); - if (!code) - DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"", - UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6)); - { - SV * const sv = core_prototype(NULL, s + 6, code, NULL); - if (sv) ret = sv; - } - goto set; - } + const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); + if (!code) + DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"", + UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6)); + { + SV * const sv = core_prototype(NULL, s + 6, code, NULL); + if (sv) ret = sv; + } + goto set; + } } cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) - ret = newSVpvn_flags( - CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv) - ); + ret = newSVpvn_flags( + CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv) + ); set: SETs(ret); RETURN; @@ -407,7 +407,7 @@ PP(pp_anoncode) dSP; CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ)); if (CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); + cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); EXTEND(SP,1); PUSHs(MUTABLE_SV(cv)); RETURN; @@ -424,20 +424,20 @@ PP(pp_refgen) { dSP; dMARK; if (GIMME_V != G_ARRAY) { - if (++MARK <= SP) - *MARK = *SP; - else - { - MEXTEND(SP, 1); - *MARK = &PL_sv_undef; - } - *MARK = refto(*MARK); - SP = MARK; - RETURN; + if (++MARK <= SP) + *MARK = *SP; + else + { + MEXTEND(SP, 1); + *MARK = &PL_sv_undef; + } + *MARK = refto(*MARK); + SP = MARK; + RETURN; } EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) - *MARK = refto(*MARK); + *MARK = refto(*MARK); RETURN; } @@ -449,18 +449,18 @@ S_refto(pTHX_ SV *sv) PERL_ARGS_ASSERT_REFTO; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { - if (LvTARGLEN(sv)) - vivify_defelem(sv); - if (!(sv = LvTARG(sv))) - sv = &PL_sv_undef; - else - SvREFCNT_inc_void_NN(sv); + if (LvTARGLEN(sv)) + vivify_defelem(sv); + if (!(sv = LvTARG(sv))) + sv = &PL_sv_undef; + else + SvREFCNT_inc_void_NN(sv); } else if (SvTYPE(sv) == SVt_PVAV) { - if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv)) - av_reify(MUTABLE_AV(sv)); - SvTEMP_off(sv); - SvREFCNT_inc_void_NN(sv); + if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv)) + av_reify(MUTABLE_AV(sv)); + SvTEMP_off(sv); + SvREFCNT_inc_void_NN(sv); } else if (SvPADTMP(sv)) { sv = newSVsv(sv); @@ -468,8 +468,8 @@ S_refto(pTHX_ SV *sv) else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem))) sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem); else { - SvTEMP_off(sv); - SvREFCNT_inc_void_NN(sv); + SvTEMP_off(sv); + SvREFCNT_inc_void_NN(sv); } rv = sv_newmortal(); sv_upgrade(rv, SVt_IV); @@ -485,7 +485,7 @@ PP(pp_ref) SvGETMAGIC(sv); if (!SvROK(sv)) { - SETs(&PL_sv_no); + SETs(&PL_sv_no); return NORMAL; } @@ -518,11 +518,11 @@ PP(pp_ref) do_sv_ref: { - dTARGET; - SETs(TARG); - sv_ref(TARG, SvRV(sv), TRUE); - SvSETMAGIC(TARG); - return NORMAL; + dTARGET; + SETs(TARG); + sv_ref(TARG, SvRV(sv), TRUE); + SvSETMAGIC(TARG); + return NORMAL; } } @@ -536,33 +536,33 @@ PP(pp_bless) if (MAXARG == 1) { curstash: - stash = CopSTASH(PL_curcop); - if (SvTYPE(stash) != SVt_PVHV) - Perl_croak(aTHX_ "Attempt to bless into a freed package"); + stash = CopSTASH(PL_curcop); + if (SvTYPE(stash) != SVt_PVHV) + Perl_croak(aTHX_ "Attempt to bless into a freed package"); } else { - SV * const ssv = POPs; - STRLEN len; - const char *ptr; - - if (!ssv) goto curstash; - SvGETMAGIC(ssv); - if (SvROK(ssv)) { - if (!SvAMAGIC(ssv)) { - frog: - Perl_croak(aTHX_ "Attempt to bless into a reference"); - } - /* SvAMAGIC is on here, but it only means potentially overloaded, - so after stringification: */ - ptr = SvPV_nomg_const(ssv,len); - /* We need to check the flag again: */ - if (!SvAMAGIC(ssv)) goto frog; - } - else ptr = SvPV_nomg_const(ssv,len); - if (len == 0) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Explicit blessing to '' (assuming package main)"); - stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv)); + SV * const ssv = POPs; + STRLEN len; + const char *ptr; + + if (!ssv) goto curstash; + SvGETMAGIC(ssv); + if (SvROK(ssv)) { + if (!SvAMAGIC(ssv)) { + frog: + Perl_croak(aTHX_ "Attempt to bless into a reference"); + } + /* SvAMAGIC is on here, but it only means potentially overloaded, + so after stringification: */ + ptr = SvPV_nomg_const(ssv,len); + /* We need to check the flag again: */ + if (!SvAMAGIC(ssv)) goto frog; + } + else ptr = SvPV_nomg_const(ssv,len); + if (len == 0) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Explicit blessing to '' (assuming package main)"); + stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv)); } (void)sv_bless(TOPs, stash); @@ -581,64 +581,64 @@ PP(pp_gelem) sv = NULL; if (elem) { - /* elem will always be NUL terminated. */ - switch (*elem) { - case 'A': - if (memEQs(elem, len, "ARRAY")) - { - tmpRef = MUTABLE_SV(GvAV(gv)); - if (tmpRef && !AvREAL((const AV *)tmpRef) - && AvREIFY((const AV *)tmpRef)) - av_reify(MUTABLE_AV(tmpRef)); - } - break; - case 'C': - if (memEQs(elem, len, "CODE")) - tmpRef = MUTABLE_SV(GvCVu(gv)); - break; - case 'F': - if (memEQs(elem, len, "FILEHANDLE")) { - tmpRef = MUTABLE_SV(GvIOp(gv)); - } - else - if (memEQs(elem, len, "FORMAT")) - tmpRef = MUTABLE_SV(GvFORM(gv)); - break; - case 'G': - if (memEQs(elem, len, "GLOB")) - tmpRef = MUTABLE_SV(gv); - break; - case 'H': - if (memEQs(elem, len, "HASH")) - tmpRef = MUTABLE_SV(GvHV(gv)); - break; - case 'I': - if (memEQs(elem, len, "IO")) - tmpRef = MUTABLE_SV(GvIOp(gv)); - break; - case 'N': - if (memEQs(elem, len, "NAME")) - sv = newSVhek(GvNAME_HEK(gv)); - break; - case 'P': - if (memEQs(elem, len, "PACKAGE")) { - const HV * const stash = GvSTASH(gv); - const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL; - sv = hek ? newSVhek(hek) : newSVpvs("__ANON__"); - } - break; - case 'S': - if (memEQs(elem, len, "SCALAR")) - tmpRef = GvSVn(gv); - break; - } + /* elem will always be NUL terminated. */ + switch (*elem) { + case 'A': + if (memEQs(elem, len, "ARRAY")) + { + tmpRef = MUTABLE_SV(GvAV(gv)); + if (tmpRef && !AvREAL((const AV *)tmpRef) + && AvREIFY((const AV *)tmpRef)) + av_reify(MUTABLE_AV(tmpRef)); + } + break; + case 'C': + if (memEQs(elem, len, "CODE")) + tmpRef = MUTABLE_SV(GvCVu(gv)); + break; + case 'F': + if (memEQs(elem, len, "FILEHANDLE")) { + tmpRef = MUTABLE_SV(GvIOp(gv)); + } + else + if (memEQs(elem, len, "FORMAT")) + tmpRef = MUTABLE_SV(GvFORM(gv)); + break; + case 'G': + if (memEQs(elem, len, "GLOB")) + tmpRef = MUTABLE_SV(gv); + break; + case 'H': + if (memEQs(elem, len, "HASH")) + tmpRef = MUTABLE_SV(GvHV(gv)); + break; + case 'I': + if (memEQs(elem, len, "IO")) + tmpRef = MUTABLE_SV(GvIOp(gv)); + break; + case 'N': + if (memEQs(elem, len, "NAME")) + sv = newSVhek(GvNAME_HEK(gv)); + break; + case 'P': + if (memEQs(elem, len, "PACKAGE")) { + const HV * const stash = GvSTASH(gv); + const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL; + sv = hek ? newSVhek(hek) : newSVpvs("__ANON__"); + } + break; + case 'S': + if (memEQs(elem, len, "SCALAR")) + tmpRef = GvSVn(gv); + break; + } } if (tmpRef) - sv = newRV(tmpRef); + sv = newRV(tmpRef); if (sv) - sv_2mortal(sv); + sv_2mortal(sv); else - sv = &PL_sv_undef; + sv = &PL_sv_undef; SETs(sv); RETURN; } @@ -652,9 +652,9 @@ PP(pp_study) (void)SvPV(sv, len); if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) { - /* Historically, study was skipped in these cases. */ - SETs(&PL_sv_no); - return NORMAL; + /* Historically, study was skipped in these cases. */ + SETs(&PL_sv_no); + return NORMAL; } /* Make study a no-op. It's no longer useful and its existence @@ -672,25 +672,25 @@ PP(pp_trans) SV *sv; if (PL_op->op_flags & OPf_STACKED) - sv = POPs; + sv = POPs; else { - EXTEND(SP,1); - if (ARGTARG) - sv = PAD_SV(ARGTARG); - else { - sv = DEFSV; - } + EXTEND(SP,1); + if (ARGTARG) + sv = PAD_SV(ARGTARG); + else { + sv = DEFSV; + } } if(PL_op->op_type == OP_TRANSR) { - STRLEN len; - const char * const pv = SvPV(sv,len); - SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv)); - do_trans(newsv); - PUSHs(newsv); + STRLEN len; + const char * const pv = SvPV(sv,len); + SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv)); + do_trans(newsv); + PUSHs(newsv); } else { - Size_t i = do_trans(sv); - mPUSHi((UV)i); + Size_t i = do_trans(sv); + mPUSHi((UV)i); } RETURN; } @@ -707,26 +707,26 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) PERL_ARGS_ASSERT_DO_CHOMP; if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs))) - return 0; + return 0; if (SvTYPE(sv) == SVt_PVAV) { - I32 i; - AV *const av = MUTABLE_AV(sv); - const I32 max = AvFILL(av); - - for (i = 0; i <= max; i++) { - sv = MUTABLE_SV(av_fetch(av, i, FALSE)); - if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) - count += do_chomp(retval, sv, chomping); - } + I32 i; + AV *const av = MUTABLE_AV(sv); + const I32 max = AvFILL(av); + + for (i = 0; i <= max; i++) { + sv = MUTABLE_SV(av_fetch(av, i, FALSE)); + if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) + count += do_chomp(retval, sv, chomping); + } return count; } else if (SvTYPE(sv) == SVt_PVHV) { - HV* const hv = MUTABLE_HV(sv); - HE* entry; + HV* const hv = MUTABLE_HV(sv); + HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) count += do_chomp(retval, hv_iterval(hv,entry), chomping); - return count; + return count; } else if (SvREADONLY(sv)) { Perl_croak_no_modify(); @@ -734,110 +734,110 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) s = SvPV(sv, len); if (chomping) { - if (s && len) { - char *temp_buffer = NULL; - SV *svrecode = NULL; - s += --len; - if (RsPARA(PL_rs)) { - if (*s != '\n') - goto nope_free_nothing; - ++count; - while (len && s[-1] == '\n') { - --len; - --s; - ++count; - } - } - else { - STRLEN rslen, rs_charlen; - const char *rsptr = SvPV_const(PL_rs, rslen); - - rs_charlen = SvUTF8(PL_rs) - ? sv_len_utf8(PL_rs) - : rslen; - - if (SvUTF8(PL_rs) != SvUTF8(sv)) { - /* Assumption is that rs is shorter than the scalar. */ - if (SvUTF8(PL_rs)) { - /* RS is utf8, scalar is 8 bit. */ - bool is_utf8 = TRUE; - temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, - &rslen, &is_utf8); - if (is_utf8) { - /* Cannot downgrade, therefore cannot possibly match. - At this point, temp_buffer is not alloced, and - is the buffer inside PL_rs, so dont free it. - */ - assert (temp_buffer == rsptr); - goto nope_free_sv; - } - rsptr = temp_buffer; - } - else { - /* RS is 8 bit, scalar is utf8. */ - temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); - rsptr = temp_buffer; - } - } - if (rslen == 1) { - if (*s != *rsptr) - goto nope_free_all; - ++count; - } - else { - if (len < rslen - 1) - goto nope_free_all; - len -= rslen - 1; - s -= rslen - 1; - if (memNE(s, rsptr, rslen)) - goto nope_free_all; - count += rs_charlen; - } - } - SvPV_force_nomg_nolen(sv); - SvCUR_set(sv, len); - *SvEND(sv) = '\0'; - SvNIOK_off(sv); - SvSETMAGIC(sv); - - nope_free_all: - Safefree(temp_buffer); - nope_free_sv: - SvREFCNT_dec(svrecode); - nope_free_nothing: ; - } + if (s && len) { + char *temp_buffer = NULL; + SV *svrecode = NULL; + s += --len; + if (RsPARA(PL_rs)) { + if (*s != '\n') + goto nope_free_nothing; + ++count; + while (len && s[-1] == '\n') { + --len; + --s; + ++count; + } + } + else { + STRLEN rslen, rs_charlen; + const char *rsptr = SvPV_const(PL_rs, rslen); + + rs_charlen = SvUTF8(PL_rs) + ? sv_len_utf8(PL_rs) + : rslen; + + if (SvUTF8(PL_rs) != SvUTF8(sv)) { + /* Assumption is that rs is shorter than the scalar. */ + if (SvUTF8(PL_rs)) { + /* RS is utf8, scalar is 8 bit. */ + bool is_utf8 = TRUE; + temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, + &rslen, &is_utf8); + if (is_utf8) { + /* Cannot downgrade, therefore cannot possibly match. + At this point, temp_buffer is not alloced, and + is the buffer inside PL_rs, so dont free it. + */ + assert (temp_buffer == rsptr); + goto nope_free_sv; + } + rsptr = temp_buffer; + } + else { + /* RS is 8 bit, scalar is utf8. */ + temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); + rsptr = temp_buffer; + } + } + if (rslen == 1) { + if (*s != *rsptr) + goto nope_free_all; + ++count; + } + else { + if (len < rslen - 1) + goto nope_free_all; + len -= rslen - 1; + s -= rslen - 1; + if (memNE(s, rsptr, rslen)) + goto nope_free_all; + count += rs_charlen; + } + } + SvPV_force_nomg_nolen(sv); + SvCUR_set(sv, len); + *SvEND(sv) = '\0'; + SvNIOK_off(sv); + SvSETMAGIC(sv); + + nope_free_all: + Safefree(temp_buffer); + nope_free_sv: + SvREFCNT_dec(svrecode); + nope_free_nothing: ; + } } else { - if (len && (!SvPOK(sv) || SvIsCOW(sv))) - s = SvPV_force_nomg(sv, len); - if (DO_UTF8(sv)) { - if (s && len) { - char * const send = s + len; - char * const start = s; - s = send - 1; - while (s > start && UTF8_IS_CONTINUATION(*s)) - s--; - if (is_utf8_string((U8*)s, send - s)) { - sv_setpvn(retval, s, send - s); - *s = '\0'; - SvCUR_set(sv, s - start); - SvNIOK_off(sv); - SvUTF8_on(retval); - } - } - else + if (len && (!SvPOK(sv) || SvIsCOW(sv))) + s = SvPV_force_nomg(sv, len); + if (DO_UTF8(sv)) { + if (s && len) { + char * const send = s + len; + char * const start = s; + s = send - 1; + while (s > start && UTF8_IS_CONTINUATION(*s)) + s--; + if (is_utf8_string((U8*)s, send - s)) { + sv_setpvn(retval, s, send - s); + *s = '\0'; + SvCUR_set(sv, s - start); + SvNIOK_off(sv); + SvUTF8_on(retval); + } + } + else SvPVCLEAR(retval); - } - else if (s && len) { - s += --len; - sv_setpvn(retval, s, 1); - *s = '\0'; - SvCUR_set(sv, len); - SvUTF8_off(sv); - SvNIOK_off(sv); - } - else + } + else if (s && len) { + s += --len; + sv_setpvn(retval, s, 1); + *s = '\0'; + SvCUR_set(sv, len); + SvUTF8_off(sv); + SvNIOK_off(sv); + } + else SvPVCLEAR(retval); - SvSETMAGIC(sv); + SvSETMAGIC(sv); } return count; } @@ -852,7 +852,7 @@ PP(pp_schop) const size_t count = do_chomp(TARG, TOPs, chomping); if (chomping) - sv_setiv(TARG, count); + sv_setiv(TARG, count); SETTARG; return NORMAL; } @@ -867,9 +867,9 @@ PP(pp_chop) size_t count = 0; while (MARK < SP) - count += do_chomp(TARG, *++MARK, chomping); + count += do_chomp(TARG, *++MARK, chomping); if (chomping) - sv_setiv(TARG, count); + sv_setiv(TARG, count); SP = ORIGMARK; XPUSHTARG; RETURN; @@ -881,34 +881,34 @@ PP(pp_undef) SV *sv; if (!PL_op->op_private) { - EXTEND(SP, 1); - RETPUSHUNDEF; + EXTEND(SP, 1); + RETPUSHUNDEF; } sv = TOPs; if (!sv) { - SETs(&PL_sv_undef); - return NORMAL; + SETs(&PL_sv_undef); + return NORMAL; } if (SvTHINKFIRST(sv)) - sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); + sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); switch (SvTYPE(sv)) { case SVt_NULL: - break; + break; case SVt_PVAV: - av_undef(MUTABLE_AV(sv)); - break; + av_undef(MUTABLE_AV(sv)); + break; case SVt_PVHV: - hv_undef(MUTABLE_HV(sv)); - break; + hv_undef(MUTABLE_HV(sv)); + break; case SVt_PVCV: - if (cv_const_sv((const CV *)sv)) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + if (cv_const_sv((const CV *)sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %" SVf " undefined", - SVfARG(CvANON((const CV *)sv) + SVfARG(CvANON((const CV *)sv) ? newSVpvs_flags("(anonymous)", SVs_TEMP) : sv_2mortal(newSVhek( CvNAMED(sv) @@ -916,22 +916,22 @@ PP(pp_undef) : GvENAME_HEK(CvGV((const CV *)sv)) )) )); - /* FALLTHROUGH */ + /* FALLTHROUGH */ case SVt_PVFM: - /* let user-undef'd sub keep its identity */ - cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME); - break; + /* let user-undef'd sub keep its identity */ + cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME); + break; case SVt_PVGV: - assert(isGV_with_GP(sv)); - assert(!SvFAKE(sv)); - { - GP *gp; + assert(isGV_with_GP(sv)); + assert(!SvFAKE(sv)); + { + GP *gp; HV *stash; /* undef *Pkg::meth_name ... */ bool method_changed = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv)) - && HvENAME_get(stash); + && HvENAME_get(stash); /* undef *Foo:: */ if((stash = GvHV((const GV *)sv))) { if(HvENAME_get(stash)) @@ -939,16 +939,16 @@ PP(pp_undef) else stash = NULL; } - SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); - gp_free(MUTABLE_GV(sv)); - Newxz(gp, 1, GP); - GvGP_set(sv, gp_ref(gp)); + SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); + gp_free(MUTABLE_GV(sv)); + Newxz(gp, 1, GP); + GvGP_set(sv, gp_ref(gp)); #ifndef PERL_DONT_CREATE_GVSV - GvSV(sv) = newSV(0); + GvSV(sv) = newSV(0); #endif - GvLINE(sv) = CopLINE(PL_curcop); - GvEGV(sv) = MUTABLE_GV(sv); - GvMULTI_on(sv); + GvLINE(sv) = CopLINE(PL_curcop); + GvEGV(sv) = MUTABLE_GV(sv); + GvMULTI_on(sv); if(stash) mro_package_moved(NULL, stash, (const GV *)sv, 0); @@ -963,16 +963,16 @@ PP(pp_undef) GvSTASH((const GV *)sv) ); - break; - } + break; + } default: - if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { - SvPV_free(sv); - SvPV_set(sv, NULL); - SvLEN_set(sv, 0); - } - SvOK_off(sv); - SvSETMAGIC(sv); + if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { + SvPV_free(sv); + SvPV_set(sv, NULL); + SvLEN_set(sv, 0); + } + SvOK_off(sv); + SvSETMAGIC(sv); } SETs(&PL_sv_undef); @@ -987,19 +987,19 @@ S_postincdec_common(pTHX_ SV *sv, SV *targ) { dSP; const bool inc = - PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; + PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; if (SvROK(sv)) - TARG = sv_newmortal(); + TARG = sv_newmortal(); sv_setsv(TARG, sv); if (inc) - sv_inc_nomg(sv); + sv_inc_nomg(sv); else sv_dec_nomg(sv); SvSETMAGIC(sv); /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (inc && !SvOK(TARG)) - sv_setiv(TARG, 0); + sv_setiv(TARG, 0); SETTARG; return NORMAL; } @@ -1020,7 +1020,7 @@ PP(pp_postinc) && SvIVX(sv) != IV_MAX) { IV iv = SvIVX(sv); - SvIV_set(sv, iv + 1); + SvIV_set(sv, iv + 1); TARGi(iv, 0); /* arg not GMG, so can't be tainted */ SETs(TARG); return NORMAL; @@ -1045,7 +1045,7 @@ PP(pp_postdec) && SvIVX(sv) != IV_MIN) { IV iv = SvIVX(sv); - SvIV_set(sv, iv - 1); + SvIV_set(sv, iv - 1); TARGi(iv, 0); /* arg not GMG, so can't be tainted */ SETs(TARG); return NORMAL; @@ -1071,33 +1071,33 @@ PP(pp_pow) we're sure it is safe; otherwise we call pow() and try to convert to integer afterwards. */ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) { - UV power; - bool baseuok; - UV baseuv; - - if (SvUOK(svr)) { - power = SvUVX(svr); - } else { - const IV iv = SvIVX(svr); - if (iv >= 0) { - power = iv; - } else { - goto float_it; /* Can't do negative powers this way. */ - } - } - - baseuok = SvUOK(svl); - if (baseuok) { - baseuv = SvUVX(svl); - } else { - const IV iv = SvIVX(svl); - if (iv >= 0) { - baseuv = iv; - baseuok = TRUE; /* effectively it's a UV now */ - } else { - baseuv = -iv; /* abs, baseuok == false records sign */ - } - } + UV power; + bool baseuok; + UV baseuv; + + if (SvUOK(svr)) { + power = SvUVX(svr); + } else { + const IV iv = SvIVX(svr); + if (iv >= 0) { + power = iv; + } else { + goto float_it; /* Can't do negative powers this way. */ + } + } + + baseuok = SvUOK(svl); + if (baseuok) { + baseuv = SvUVX(svl); + } else { + const IV iv = SvIVX(svl); + if (iv >= 0) { + baseuv = iv; + baseuok = TRUE; /* effectively it's a UV now */ + } else { + baseuv = -iv; /* abs, baseuok == false records sign */ + } + } /* now we have integer ** positive integer. */ is_int = 1; @@ -1114,67 +1114,67 @@ PP(pp_pow) NV result = 1.0; NV base = baseuok ? baseuv : -(NV)baseuv; - if (power & 1) { - result *= base; - } - while (power >>= 1) { - base *= base; - if (power & 1) { - result *= base; - } - } + if (power & 1) { + result *= base; + } + while (power >>= 1) { + base *= base; + if (power & 1) { + result *= base; + } + } SP--; SETn( result ); SvIV_please_nomg(svr); RETURN; - } else { - unsigned int highbit = 8 * sizeof(UV); - unsigned int diff = 8 * sizeof(UV); - while (diff >>= 1) { - highbit -= diff; - if (baseuv >> highbit) { - highbit += diff; - } - } - /* we now have baseuv < 2 ** highbit */ - if (power * highbit <= 8 * sizeof(UV)) { - /* result will definitely fit in UV, so use UV math - on same algorithm as above */ - UV result = 1; - UV base = baseuv; - const bool odd_power = cBOOL(power & 1); - if (odd_power) { - result *= base; - } - while (power >>= 1) { - base *= base; - if (power & 1) { - result *= base; - } - } - SP--; - if (baseuok || !odd_power) - /* answer is positive */ - SETu( result ); - else if (result <= (UV)IV_MAX) - /* answer negative, fits in IV */ - SETi( -(IV)result ); - else if (result == (UV)IV_MIN) - /* 2's complement assumption: special case IV_MIN */ - SETi( IV_MIN ); - else - /* answer negative, doesn't fit */ - SETn( -(NV)result ); - RETURN; - } - } + } else { + unsigned int highbit = 8 * sizeof(UV); + unsigned int diff = 8 * sizeof(UV); + while (diff >>= 1) { + highbit -= diff; + if (baseuv >> highbit) { + highbit += diff; + } + } + /* we now have baseuv < 2 ** highbit */ + if (power * highbit <= 8 * sizeof(UV)) { + /* result will definitely fit in UV, so use UV math + on same algorithm as above */ + UV result = 1; + UV base = baseuv; + const bool odd_power = cBOOL(power & 1); + if (odd_power) { + result *= base; + } + while (power >>= 1) { + base *= base; + if (power & 1) { + result *= base; + } + } + SP--; + if (baseuok || !odd_power) + /* answer is positive */ + SETu( result ); + else if (result <= (UV)IV_MAX) + /* answer negative, fits in IV */ + SETi( -(IV)result ); + else if (result == (UV)IV_MIN) + /* 2's complement assumption: special case IV_MIN */ + SETi( IV_MIN ); + else + /* answer negative, doesn't fit */ + SETn( -(NV)result ); + RETURN; + } + } } float_it: #endif { - NV right = SvNV_nomg(svr); - NV left = SvNV_nomg(svl); - (void)POPs; + NV right = SvNV_nomg(svr); + NV left = SvNV_nomg(svl); + (void)POPs; #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG) /* @@ -1184,43 +1184,43 @@ PP(pp_pow) 03/06/2006. The problem exists in at least the following versions of AIX and the libm fileset, and no doubt others as well: - AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50 - AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29 - AIX 5.2.0 bos.adt.libm 5.2.0.85 + AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50 + AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29 + AIX 5.2.0 bos.adt.libm 5.2.0.85 So, until IBM fixes powl(), we provide the following workaround to handle the problem ourselves. Our logic is as follows: for negative bases (left), we use fmod(right, 2) to check if the exponent is an odd or even integer: - - if odd, powl(left, right) == -powl(-left, right) - - if even, powl(left, right) == powl(-left, right) + - if odd, powl(left, right) == -powl(-left, right) + - if even, powl(left, right) == powl(-left, right) If the exponent is not an integer, the result is rightly NaNQ, so we just return that (as NV_NAN). */ - if (left < 0.0) { - NV mod2 = Perl_fmod( right, 2.0 ); - if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */ - SETn( -Perl_pow( -left, right) ); - } else if (mod2 == 0.0) { /* even integer */ - SETn( Perl_pow( -left, right) ); - } else { /* fractional power */ - SETn( NV_NAN ); - } - } else { - SETn( Perl_pow( left, right) ); - } + if (left < 0.0) { + NV mod2 = Perl_fmod( right, 2.0 ); + if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */ + SETn( -Perl_pow( -left, right) ); + } else if (mod2 == 0.0) { /* even integer */ + SETn( Perl_pow( -left, right) ); + } else { /* fractional power */ + SETn( NV_NAN ); + } + } else { + SETn( Perl_pow( left, right) ); + } #else - SETn( Perl_pow( left, right) ); + SETn( Perl_pow( left, right) ); #endif /* HAS_AIX_POWL_NEG_BASE_BUG */ #ifdef PERL_PRESERVE_IVUV - if (is_int) - SvIV_please_nomg(svr); + if (is_int) + SvIV_please_nomg(svr); #endif - RETURN; + RETURN; } } @@ -1288,117 +1288,117 @@ PP(pp_multiply) generic: if (SvIV_please_nomg(svr)) { - /* Unless the left argument is integer in range we are going to have to - use NV maths. Hence only attempt to coerce the right argument if - we know the left is integer. */ - /* Left operand is defined, so is it IV? */ - if (SvIV_please_nomg(svl)) { - bool auvok = SvUOK(svl); - bool buvok = SvUOK(svr); - const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); - const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); - UV alow; - UV ahigh; - UV blow; - UV bhigh; - - if (auvok) { - alow = SvUVX(svl); - } else { - const IV aiv = SvIVX(svl); - if (aiv >= 0) { - alow = aiv; - auvok = TRUE; /* effectively it's a UV now */ - } else { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + /* Left operand is defined, so is it IV? */ + if (SvIV_please_nomg(svl)) { + bool auvok = SvUOK(svl); + bool buvok = SvUOK(svr); + const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); + const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); + UV alow; + UV ahigh; + UV blow; + UV bhigh; + + if (auvok) { + alow = SvUVX(svl); + } else { + const IV aiv = SvIVX(svl); + if (aiv >= 0) { + alow = aiv; + auvok = TRUE; /* effectively it's a UV now */ + } else { /* abs, auvok == false records sign; Using 0- here and * later to silence bogus warning from MS VC */ - alow = (UV) (0 - (UV) aiv); - } - } - if (buvok) { - blow = SvUVX(svr); - } else { - const IV biv = SvIVX(svr); - if (biv >= 0) { - blow = biv; - buvok = TRUE; /* effectively it's a UV now */ - } else { + alow = (UV) (0 - (UV) aiv); + } + } + if (buvok) { + blow = SvUVX(svr); + } else { + const IV biv = SvIVX(svr); + if (biv >= 0) { + blow = biv; + buvok = TRUE; /* effectively it's a UV now */ + } else { /* abs, buvok == false records sign */ - blow = (UV) (0 - (UV) biv); - } - } - - /* If this does sign extension on unsigned it's time for plan B */ - ahigh = alow >> (4 * sizeof (UV)); - alow &= botmask; - bhigh = blow >> (4 * sizeof (UV)); - blow &= botmask; - if (ahigh && bhigh) { - NOOP; - /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 - which is overflow. Drop to NVs below. */ - } else if (!ahigh && !bhigh) { - /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 - so the unsigned multiply cannot overflow. */ - const UV product = alow * blow; - if (auvok == buvok) { - /* -ve * -ve or +ve * +ve gives a +ve result. */ - SP--; - SETu( product ); - RETURN; - } else if (product <= (UV)IV_MIN) { - /* 2s complement assumption that (UV)-IV_MIN is correct. */ - /* -ve result, which could overflow an IV */ - SP--; + blow = (UV) (0 - (UV) biv); + } + } + + /* If this does sign extension on unsigned it's time for plan B */ + ahigh = alow >> (4 * sizeof (UV)); + alow &= botmask; + bhigh = blow >> (4 * sizeof (UV)); + blow &= botmask; + if (ahigh && bhigh) { + NOOP; + /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 + which is overflow. Drop to NVs below. */ + } else if (!ahigh && !bhigh) { + /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 + so the unsigned multiply cannot overflow. */ + const UV product = alow * blow; + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product ); + RETURN; + } else if (product <= (UV)IV_MIN) { + /* 2s complement assumption that (UV)-IV_MIN is correct. */ + /* -ve result, which could overflow an IV */ + SP--; /* can't negate IV_MIN, but there are aren't two * integers such that !ahigh && !bhigh, where the * product equals 0x800....000 */ assert(product != (UV)IV_MIN); - SETi( -(IV)product ); - RETURN; - } /* else drop to NVs below. */ - } else { - /* One operand is large, 1 small */ - UV product_middle; - if (bhigh) { - /* swap the operands */ - ahigh = bhigh; - bhigh = blow; /* bhigh now the temp var for the swap */ - blow = alow; - alow = bhigh; - } - /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) - multiplies can't overflow. shift can, add can, -ve can. */ - product_middle = ahigh * blow; - if (!(product_middle & topmask)) { - /* OK, (ahigh * blow) won't lose bits when we shift it. */ - UV product_low; - product_middle <<= (4 * sizeof (UV)); - product_low = alow * blow; - - /* as for pp_add, UV + something mustn't get smaller. - IIRC ANSI mandates this wrapping *behaviour* for - unsigned whatever the actual representation*/ - product_low += product_middle; - if (product_low >= product_middle) { - /* didn't overflow */ - if (auvok == buvok) { - /* -ve * -ve or +ve * +ve gives a +ve result. */ - SP--; - SETu( product_low ); - RETURN; - } else if (product_low <= (UV)IV_MIN) { - /* 2s complement assumption again */ - /* -ve result, which could overflow an IV */ - SP--; - SETi(product_low == (UV)IV_MIN + SETi( -(IV)product ); + RETURN; + } /* else drop to NVs below. */ + } else { + /* One operand is large, 1 small */ + UV product_middle; + if (bhigh) { + /* swap the operands */ + ahigh = bhigh; + bhigh = blow; /* bhigh now the temp var for the swap */ + blow = alow; + alow = bhigh; + } + /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) + multiplies can't overflow. shift can, add can, -ve can. */ + product_middle = ahigh * blow; + if (!(product_middle & topmask)) { + /* OK, (ahigh * blow) won't lose bits when we shift it. */ + UV product_low; + product_middle <<= (4 * sizeof (UV)); + product_low = alow * blow; + + /* as for pp_add, UV + something mustn't get smaller. + IIRC ANSI mandates this wrapping *behaviour* for + unsigned whatever the actual representation*/ + product_low += product_middle; + if (product_low >= product_middle) { + /* didn't overflow */ + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product_low ); + RETURN; + } else if (product_low <= (UV)IV_MIN) { + /* 2s complement assumption again */ + /* -ve result, which could overflow an IV */ + SP--; + SETi(product_low == (UV)IV_MIN ? IV_MIN : -(IV)product_low); - RETURN; - } /* else drop to NVs below. */ - } - } /* product_middle too large */ - } /* ahigh && bhigh */ - } /* SvIOK(svl) */ + RETURN; + } /* else drop to NVs below. */ + } + } /* product_middle too large */ + } /* ahigh && bhigh */ + } /* SvIOK(svl) */ } /* SvIOK(svr) */ #endif { @@ -1448,13 +1448,13 @@ PP(pp_divide) if (right_non_neg) { right = SvUVX(svr); } - else { - const IV biv = SvIVX(svr); + else { + const IV biv = SvIVX(svr); if (biv >= 0) { right = biv; right_non_neg = TRUE; /* effectively it's a UV now */ } - else { + else { right = -(UV)biv; } } @@ -1469,13 +1469,13 @@ PP(pp_divide) if (left_non_neg) { left = SvUVX(svl); } - else { - const IV aiv = SvIVX(svl); + else { + const IV aiv = SvIVX(svl); if (aiv >= 0) { left = aiv; left_non_neg = TRUE; /* effectively it's a UV now */ } - else { + else { left = -(UV)aiv; } } @@ -1499,7 +1499,7 @@ PP(pp_divide) /* Modern compilers optimize division followed by * modulo into a single div instruction */ - const UV result = left / right; + const UV result = left / right; if (left % right == 0) { SP--; /* result is valid */ if (left_non_neg == right_non_neg) { @@ -1520,17 +1520,17 @@ PP(pp_divide) } /* one operand wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ { - NV right = SvNV_nomg(svr); - NV left = SvNV_nomg(svl); - (void)POPs;(void)POPs; + NV right = SvNV_nomg(svr); + NV left = SvNV_nomg(svl); + (void)POPs;(void)POPs; #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - if (! Perl_isnan(right) && right == 0.0) + if (! Perl_isnan(right) && right == 0.0) #else - if (right == 0.0) + if (right == 0.0) #endif - DIE(aTHX_ "Illegal division by zero"); - PUSHn( left / right ); - RETURN; + DIE(aTHX_ "Illegal division by zero"); + PUSHn( left / right ); + RETURN; } } @@ -1539,52 +1539,52 @@ PP(pp_modulo) dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric); { - UV left = 0; - UV right = 0; - bool left_neg = FALSE; - bool right_neg = FALSE; - bool use_double = FALSE; - bool dright_valid = FALSE; - NV dright = 0.0; - NV dleft = 0.0; - SV * const svr = TOPs; - SV * const svl = TOPm1s; + UV left = 0; + UV right = 0; + bool left_neg = FALSE; + bool right_neg = FALSE; + bool use_double = FALSE; + bool dright_valid = FALSE; + NV dright = 0.0; + NV dleft = 0.0; + SV * const svr = TOPs; + SV * const svl = TOPm1s; if (SvIV_please_nomg(svr)) { right_neg = !SvUOK(svr); if (!right_neg) { right = SvUVX(svr); } else { - const IV biv = SvIVX(svr); + const IV biv = SvIVX(svr); if (biv >= 0) { right = biv; right_neg = FALSE; /* effectively it's a UV now */ } else { - right = (UV) (0 - (UV) biv); + right = (UV) (0 - (UV) biv); } } } else { - dright = SvNV_nomg(svr); - right_neg = dright < 0; - if (right_neg) - dright = -dright; + dright = SvNV_nomg(svr); + right_neg = dright < 0; + if (right_neg) + dright = -dright; if (dright < UV_MAX_P1) { right = U_V(dright); dright_valid = TRUE; /* In case we need to use double below. */ } else { use_double = TRUE; } - } + } /* At this point use_double is only true if right is out of range for a UV. In range NV has been rounded down to nearest UV and use_double false. */ - if (!use_double && SvIV_please_nomg(svl)) { + if (!use_double && SvIV_please_nomg(svl)) { left_neg = !SvUOK(svl); if (!left_neg) { left = SvUVX(svl); } else { - const IV aiv = SvIVX(svl); + const IV aiv = SvIVX(svl); if (aiv >= 0) { left = aiv; left_neg = FALSE; /* effectively it's a UV now */ @@ -1593,15 +1593,15 @@ PP(pp_modulo) } } } - else { - dleft = SvNV_nomg(svl); - left_neg = dleft < 0; - if (left_neg) - dleft = -dleft; + else { + dleft = SvNV_nomg(svl); + left_neg = dleft < 0; + if (left_neg) + dleft = -dleft; /* This should be exactly the 5.6 behaviour - if left and right are both in range for UV then use U_V() rather than floor. */ - if (!use_double) { + if (!use_double) { if (dleft < UV_MAX_P1) { /* right was in range, so is dleft, so use UVs not double. */ @@ -1622,42 +1622,42 @@ PP(pp_modulo) } } } - sp -= 2; - if (use_double) { - NV dans; - - if (!dright) - DIE(aTHX_ "Illegal modulus zero"); - - dans = Perl_fmod(dleft, dright); - if ((left_neg != right_neg) && dans) - dans = dright - dans; - if (right_neg) - dans = -dans; - sv_setnv(TARG, dans); - } - else { - UV ans; - - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - - ans = left % right; - if ((left_neg != right_neg) && ans) - ans = right - ans; - if (right_neg) { - /* XXX may warn: unary minus operator applied to unsigned type */ - /* could change -foo to be (~foo)+1 instead */ - if (ans <= ~((UV)IV_MAX)+1) - sv_setiv(TARG, ~ans+1); - else - sv_setnv(TARG, -(NV)ans); - } - else - sv_setuv(TARG, ans); - } - PUSHTARG; - RETURN; + sp -= 2; + if (use_double) { + NV dans; + + if (!dright) + DIE(aTHX_ "Illegal modulus zero"); + + dans = Perl_fmod(dleft, dright); + if ((left_neg != right_neg) && dans) + dans = dright - dans; + if (right_neg) + dans = -dans; + sv_setnv(TARG, dans); + } + else { + UV ans; + + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + + ans = left % right; + if ((left_neg != right_neg) && ans) + ans = right - ans; + if (right_neg) { + /* XXX may warn: unary minus operator applied to unsigned type */ + /* could change -foo to be (~foo)+1 instead */ + if (ans <= ~((UV)IV_MAX)+1) + sv_setiv(TARG, ~ans+1); + else + sv_setnv(TARG, -(NV)ans); + } + else + sv_setuv(TARG, ans); + } + PUSHTARG; + RETURN; } } @@ -1670,45 +1670,45 @@ PP(pp_repeat) const U8 gimme = GIMME_V; if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { - /* TODO: think of some way of doing list-repeat overloading ??? */ - sv = POPs; - SvGETMAGIC(sv); + /* TODO: think of some way of doing list-repeat overloading ??? */ + sv = POPs; + SvGETMAGIC(sv); } else { - if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) { - /* The parser saw this as a list repeat, and there - are probably several items on the stack. But we're - in scalar/void context, and there's no pp_list to save us - now. So drop the rest of the items -- robin@kitsite.com - */ - dMARK; - if (MARK + 1 < SP) { - MARK[1] = TOPm1s; - MARK[2] = TOPs; - } - else { - dTOPss; - ASSUME(MARK + 1 == SP); + if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) { + /* The parser saw this as a list repeat, and there + are probably several items on the stack. But we're + in scalar/void context, and there's no pp_list to save us + now. So drop the rest of the items -- robin@kitsite.com + */ + dMARK; + if (MARK + 1 < SP) { + MARK[1] = TOPm1s; + MARK[2] = TOPs; + } + else { + dTOPss; + ASSUME(MARK + 1 == SP); MEXTEND(SP, 1); PUSHs(sv); - MARK[1] = &PL_sv_undef; - } - SP = MARK + 2; - } - tryAMAGICbin_MG(repeat_amg, AMGf_assign); - sv = POPs; + MARK[1] = &PL_sv_undef; + } + SP = MARK + 2; + } + tryAMAGICbin_MG(repeat_amg, AMGf_assign); + sv = POPs; } if (SvIOKp(sv)) { - if (SvUOK(sv)) { - const UV uv = SvUV_nomg(sv); - if (uv > IV_MAX) - count = IV_MAX; /* The best we can do? */ - else - count = uv; - } else { - count = SvIV_nomg(sv); - } + if (SvUOK(sv)) { + const UV uv = SvUV_nomg(sv); + if (uv > IV_MAX) + count = IV_MAX; /* The best we can do? */ + else + count = uv; + } else { + count = SvIV_nomg(sv); + } } else if (SvNOKp(sv)) { const NV nv = SvNV_nomg(sv); @@ -1723,7 +1723,7 @@ PP(pp_repeat) } } else - count = SvIV_nomg(sv); + count = SvIV_nomg(sv); if (infnan) { Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), @@ -1735,12 +1735,12 @@ PP(pp_repeat) } if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { - dMARK; - const SSize_t items = SP - MARK; - const U8 mod = PL_op->op_flags & OPf_MOD; + dMARK; + const SSize_t items = SP - MARK; + const U8 mod = PL_op->op_flags & OPf_MOD; - if (count > 1) { - SSize_t max; + if (count > 1) { + SSize_t max; if ( items > SSize_t_MAX / count /* max would overflow */ /* repeatcpy would overflow */ @@ -1750,57 +1750,57 @@ PP(pp_repeat) max = items * count; MEXTEND(MARK, max); - while (SP > MARK) { + while (SP > MARK) { if (*SP) { if (mod && SvPADTMP(*SP)) { *SP = sv_mortalcopy(*SP); } - SvTEMP_off((*SP)); - } - SP--; - } - MARK++; - repeatcpy((char*)(MARK + items), (char*)MARK, - items * sizeof(const SV *), count - 1); - SP += max; - } - else if (count <= 0) - SP = MARK; + SvTEMP_off((*SP)); + } + SP--; + } + MARK++; + repeatcpy((char*)(MARK + items), (char*)MARK, + items * sizeof(const SV *), count - 1); + SP += max; + } + else if (count <= 0) + SP = MARK; } else { /* Note: mark already snarfed by pp_list */ - SV * const tmpstr = POPs; - STRLEN len; - bool isutf; - - if (TARG != tmpstr) - sv_setsv_nomg(TARG, tmpstr); - SvPV_force_nomg(TARG, len); - isutf = DO_UTF8(TARG); - if (count != 1) { - if (count < 1) - SvCUR_set(TARG, 0); - else { - STRLEN max; - - if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */ - || len > (U32)I32_MAX /* repeatcpy would overflow */ + SV * const tmpstr = POPs; + STRLEN len; + bool isutf; + + if (TARG != tmpstr) + sv_setsv_nomg(TARG, tmpstr); + SvPV_force_nomg(TARG, len); + isutf = DO_UTF8(TARG); + if (count != 1) { + if (count < 1) + SvCUR_set(TARG, 0); + else { + STRLEN max; + + if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */ + || len > (U32)I32_MAX /* repeatcpy would overflow */ ) - Perl_croak(aTHX_ "%s", + Perl_croak(aTHX_ "%s", "Out of memory during string extend"); - max = (UV)count * len + 1; - SvGROW(TARG, max); + max = (UV)count * len + 1; + SvGROW(TARG, max); - repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); - SvCUR_set(TARG, SvCUR(TARG) * count); - } - *SvEND(TARG) = '\0'; - } - if (isutf) - (void)SvPOK_only_UTF8(TARG); - else - (void)SvPOK_only(TARG); + repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); + SvCUR_set(TARG, SvCUR(TARG) * count); + } + *SvEND(TARG) = '\0'; + } + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); - PUSHTARG; + PUSHTARG; } RETURN; } @@ -1860,114 +1860,114 @@ PP(pp_subtract) /* See comments in pp_add (in pp_hot.c) about Overflow, and how "bad things" happen if you rely on signed integers wrapping. */ if (SvIV_please_nomg(svr)) { - /* Unless the left argument is integer in range we are going to have to - use NV maths. Hence only attempt to coerce the right argument if - we know the left is integer. */ - UV auv = 0; - bool auvok = FALSE; - bool a_valid = 0; - - if (!useleft) { - auv = 0; - a_valid = auvok = 1; - /* left operand is undef, treat as zero. */ - } else { - /* Left operand is defined, so is it IV? */ - if (SvIV_please_nomg(svl)) { - if ((auvok = SvUOK(svl))) - auv = SvUVX(svl); - else { - const IV aiv = SvIVX(svl); - if (aiv >= 0) { - auv = aiv; - auvok = 1; /* Now acting as a sign flag. */ - } else { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + UV auv = 0; + bool auvok = FALSE; + bool a_valid = 0; + + if (!useleft) { + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. */ + } else { + /* Left operand is defined, so is it IV? */ + if (SvIV_please_nomg(svl)) { + if ((auvok = SvUOK(svl))) + auv = SvUVX(svl); + else { + const IV aiv = SvIVX(svl); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { auv = (UV) (0 - (UV) aiv); - } - } - a_valid = 1; - } - } - if (a_valid) { - bool result_good = 0; - UV result; - UV buv; - bool buvok = SvUOK(svr); - - if (buvok) - buv = SvUVX(svr); - else { - const IV biv = SvIVX(svr); - if (biv >= 0) { - buv = biv; - buvok = 1; - } else + } + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + UV buv; + bool buvok = SvUOK(svr); + + if (buvok) + buv = SvUVX(svr); + else { + const IV biv = SvIVX(svr); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else buv = (UV) (0 - (UV) biv); - } - /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, - else "IV" now, independent of how it came in. - if a, b represents positive, A, B negative, a maps to -A etc - a - b => (a - b) - A - b => -(a + b) - a - B => (a + b) - A - B => -(a - b) - all UV maths. negate result if A negative. - subtract if signs same, add if signs differ. */ - - if (auvok ^ buvok) { - /* Signs differ. */ - result = auv + buv; - if (result >= auv) - result_good = 1; - } else { - /* Signs same */ - if (auv >= buv) { - result = auv - buv; - /* Must get smaller */ - if (result <= auv) - result_good = 1; - } else { - result = buv - auv; - if (result <= buv) { - /* result really should be -(auv-buv). as its negation - of true value, need to swap our result flag */ - auvok = !auvok; - result_good = 1; - } - } - } - if (result_good) { - SP--; - if (auvok) - SETu( result ); - else { - /* Negate result */ - if (result <= (UV)IV_MIN) + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independent of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a - b => (a - b) + A - b => -(a + b) + a - B => (a + b) + A - B => -(a - b) + all UV maths. negate result if A negative. + subtract if signs same, add if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } else { + /* Signs same */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; + } + } + } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); - else { - /* result valid, but out of range for IV. */ - SETn( -(NV)result ); - } - } - RETURN; - } /* Overflow, drop through to NVs. */ - } + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ + } } #else useleft = USE_LEFT(svl); #endif { - NV value = SvNV_nomg(svr); - (void)POPs; + NV value = SvNV_nomg(svr); + (void)POPs; - if (!useleft) { - /* left operand is undef, treat as zero - value */ - SETn(-value); - RETURN; - } - SETn( SvNV_nomg(svl) - value ); - RETURN; + if (!useleft) { + /* left operand is undef, treat as zero - value */ + SETn(-value); + RETURN; + } + SETn( SvNV_nomg(svl) - value ); + RETURN; } } @@ -2047,7 +2047,7 @@ PP(pp_left_shift) SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift)); } else { - SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift)); + SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift)); } RETURN; } @@ -2062,7 +2062,7 @@ PP(pp_right_shift) { const int shift = S_shift_amount(aTHX_ svr); if (PL_op->op_private & HINT_INTEGER) { - SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift)); + SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift)); } else { SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift)); @@ -2194,41 +2194,41 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) { - if (!SvUOK(left)) { - const IV leftiv = SvIVX(left); - if (!SvUOK(right)) { - /* ## IV <=> IV ## */ - const IV rightiv = SvIVX(right); - return (leftiv > rightiv) - (leftiv < rightiv); - } - /* ## IV <=> UV ## */ - if (leftiv < 0) - /* As (b) is a UV, it's >=0, so it must be < */ - return -1; - { - const UV rightuv = SvUVX(right); - return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); - } - } - - if (SvUOK(right)) { - /* ## UV <=> UV ## */ - const UV leftuv = SvUVX(left); - const UV rightuv = SvUVX(right); - return (leftuv > rightuv) - (leftuv < rightuv); - } - /* ## UV <=> IV ## */ - { - const IV rightiv = SvIVX(right); - if (rightiv < 0) - /* As (a) is a UV, it's >=0, so it cannot be < */ - return 1; - { - const UV leftuv = SvUVX(left); - return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); - } - } - NOT_REACHED; /* NOTREACHED */ + if (!SvUOK(left)) { + const IV leftiv = SvIVX(left); + if (!SvUOK(right)) { + /* ## IV <=> IV ## */ + const IV rightiv = SvIVX(right); + return (leftiv > rightiv) - (leftiv < rightiv); + } + /* ## IV <=> UV ## */ + if (leftiv < 0) + /* As (b) is a UV, it's >=0, so it must be < */ + return -1; + { + const UV rightuv = SvUVX(right); + return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); + } + } + + if (SvUOK(right)) { + /* ## UV <=> UV ## */ + const UV leftuv = SvUVX(left); + const UV rightuv = SvUVX(right); + return (leftuv > rightuv) - (leftuv < rightuv); + } + /* ## UV <=> IV ## */ + { + const IV rightiv = SvIVX(right); + if (rightiv < 0) + /* As (a) is a UV, it's >=0, so it cannot be < */ + return 1; + { + const UV leftuv = SvUVX(left); + return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); + } + } + NOT_REACHED; /* NOTREACHED */ } #endif { @@ -2237,16 +2237,16 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) if (Perl_isnan(lnv) || Perl_isnan(rnv)) { - return 2; + return 2; } return (lnv > rnv) - (lnv < rnv); #else if (lnv < rnv) - return -1; + return -1; if (lnv > rnv) - return 1; + return 1; if (lnv == rnv) - return 0; + return 0; return 2; #endif } @@ -2263,11 +2263,11 @@ PP(pp_ncmp) left = TOPs; value = do_ncmp(left, right); if (value == 2) { - SETs(&PL_sv_undef); + SETs(&PL_sv_undef); } else { - dTARGET; - SETi(value); + dTARGET; + SETi(value); } RETURN; } @@ -2285,21 +2285,21 @@ PP(pp_sle) switch (PL_op->op_type) { case OP_SLT: - amg_type = slt_amg; - /* cmp < 0 */ - rhs = 0; - break; + amg_type = slt_amg; + /* cmp < 0 */ + rhs = 0; + break; case OP_SGT: - amg_type = sgt_amg; - /* cmp > 0 */ - multiplier = -1; - rhs = 0; - break; + amg_type = sgt_amg; + /* cmp > 0 */ + multiplier = -1; + rhs = 0; + break; case OP_SGE: - amg_type = sge_amg; - /* cmp >= 0 */ - multiplier = -1; - break; + amg_type = sge_amg; + /* cmp >= 0 */ + multiplier = -1; + break; } tryAMAGICbin_MG(amg_type, 0); @@ -2308,10 +2308,10 @@ PP(pp_sle) const int cmp = #ifdef USE_LOCALE_COLLATE (IN_LC_RUNTIME(LC_COLLATE)) - ? sv_cmp_locale_flags(left, right, 0) + ? sv_cmp_locale_flags(left, right, 0) : #endif - sv_cmp_flags(left, right, 0); + sv_cmp_flags(left, right, 0); SETs(boolSV(cmp * multiplier < rhs)); RETURN; } @@ -2348,8 +2348,8 @@ PP(pp_scmp) const int cmp = #ifdef USE_LOCALE_COLLATE (IN_LC_RUNTIME(LC_COLLATE)) - ? sv_cmp_locale_flags(left, right, 0) - : + ? sv_cmp_locale_flags(left, right, 0) + : #endif sv_cmp_flags(left, right, 0); SETi( cmp ); @@ -2364,22 +2364,22 @@ PP(pp_bit_and) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); - const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); - if (PL_op->op_private & HINT_INTEGER) { - const IV i = SvIV_nomg(left) & SvIV_nomg(right); - SETi(i); - } - else { - const UV u = SvUV_nomg(left) & SvUV_nomg(right); - SETu(u); - } - if (left_ro_nonnum && left != TARG) SvNIOK_off(left); - if (right_ro_nonnum) SvNIOK_off(right); + const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); + const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); + if (PL_op->op_private & HINT_INTEGER) { + const IV i = SvIV_nomg(left) & SvIV_nomg(right); + SETi(i); + } + else { + const UV u = SvUV_nomg(left) & SvUV_nomg(right); + SETu(u); + } + if (left_ro_nonnum && left != TARG) SvNIOK_off(left); + if (right_ro_nonnum) SvNIOK_off(right); } else { - do_vop(PL_op->op_type, TARG, left, right); - SETTARG; + do_vop(PL_op->op_type, TARG, left, right); + SETTARG; } RETURN; } @@ -2390,15 +2390,15 @@ PP(pp_nbit_and) dSP; tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg); { - dATARGET; dPOPTOPssrl; - if (PL_op->op_private & HINT_INTEGER) { - const IV i = SvIV_nomg(left) & SvIV_nomg(right); - SETi(i); - } - else { - const UV u = SvUV_nomg(left) & SvUV_nomg(right); - SETu(u); - } + dATARGET; dPOPTOPssrl; + if (PL_op->op_private & HINT_INTEGER) { + const IV i = SvIV_nomg(left) & SvIV_nomg(right); + SETi(i); + } + else { + const UV u = SvUV_nomg(left) & SvUV_nomg(right); + SETu(u); + } } RETURN; } @@ -2408,9 +2408,9 @@ PP(pp_sbit_and) dSP; tryAMAGICbin_MG(sband_amg, AMGf_assign); { - dATARGET; dPOPTOPssrl; - do_vop(OP_BIT_AND, TARG, left, right); - RETSETTARG; + dATARGET; dPOPTOPssrl; + do_vop(OP_BIT_AND, TARG, left, right); + RETSETTARG; } } @@ -2425,26 +2425,26 @@ PP(pp_bit_or) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); - const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); - if (PL_op->op_private & HINT_INTEGER) { - const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); - const IV r = SvIV_nomg(right); - const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); - SETi(result); - } - else { - const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); - const UV r = SvUV_nomg(right); - const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); - SETu(result); - } - if (left_ro_nonnum && left != TARG) SvNIOK_off(left); - if (right_ro_nonnum) SvNIOK_off(right); + const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); + const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); + if (PL_op->op_private & HINT_INTEGER) { + const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); + const IV r = SvIV_nomg(right); + const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETi(result); + } + else { + const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); + const UV r = SvUV_nomg(right); + const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETu(result); + } + if (left_ro_nonnum && left != TARG) SvNIOK_off(left); + if (right_ro_nonnum) SvNIOK_off(right); } else { - do_vop(op_type, TARG, left, right); - SETTARG; + do_vop(op_type, TARG, left, right); + SETTARG; } RETURN; } @@ -2458,21 +2458,21 @@ PP(pp_nbit_or) const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg), - AMGf_assign|AMGf_numarg); + AMGf_assign|AMGf_numarg); { - dATARGET; dPOPTOPssrl; - if (PL_op->op_private & HINT_INTEGER) { - const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); - const IV r = SvIV_nomg(right); - const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); - SETi(result); - } - else { - const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); - const UV r = SvUV_nomg(right); - const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); - SETu(result); - } + dATARGET; dPOPTOPssrl; + if (PL_op->op_private & HINT_INTEGER) { + const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); + const IV r = SvIV_nomg(right); + const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); + SETi(result); + } + else { + const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); + const UV r = SvUV_nomg(right); + const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); + SETu(result); + } } RETURN; } @@ -2485,12 +2485,12 @@ PP(pp_sbit_or) const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg), - AMGf_assign); + AMGf_assign); { - dATARGET; dPOPTOPssrl; - do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left, - right); - RETSETTARG; + dATARGET; dPOPTOPssrl; + do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left, + right); + RETSETTARG; } } @@ -2502,15 +2502,15 @@ S_negate_string(pTHX) const char *s; SV * const sv = TOPs; if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv))) - return FALSE; + return FALSE; s = SvPV_nomg_const(sv, len); if (isIDFIRST(*s)) { - sv_setpvs(TARG, "-"); - sv_catsv(TARG, sv); + sv_setpvs(TARG, "-"); + sv_catsv(TARG, sv); } else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { - sv_setsv_nomg(TARG, sv); - *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; + sv_setsv_nomg(TARG, sv); + *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; } else return FALSE; SETTARG; @@ -2523,40 +2523,40 @@ PP(pp_negate) tryAMAGICun_MG(neg_amg, AMGf_numeric); if (S_negate_string(aTHX)) return NORMAL; { - SV * const sv = TOPs; - - if (SvIOK(sv)) { - /* It's publicly an integer */ - oops_its_an_int: - if (SvIsUV(sv)) { - if (SvIVX(sv) == IV_MIN) { - /* 2s complement assumption. */ + SV * const sv = TOPs; + + if (SvIOK(sv)) { + /* It's publicly an integer */ + oops_its_an_int: + if (SvIsUV(sv)) { + if (SvIVX(sv) == IV_MIN) { + /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ return NORMAL; - } - else if (SvUVX(sv) <= IV_MAX) { - SETi(-SvIVX(sv)); - return NORMAL; - } - } - else if (SvIVX(sv) != IV_MIN) { - SETi(-SvIVX(sv)); - return NORMAL; - } + } + else if (SvUVX(sv) <= IV_MAX) { + SETi(-SvIVX(sv)); + return NORMAL; + } + } + else if (SvIVX(sv) != IV_MIN) { + SETi(-SvIVX(sv)); + return NORMAL; + } #ifdef PERL_PRESERVE_IVUV - else { - SETu((UV)IV_MIN); - return NORMAL; - } + else { + SETu((UV)IV_MIN); + return NORMAL; + } #endif - } - if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) - SETn(-SvNV_nomg(sv)); - else if (SvPOKp(sv) && SvIV_please_nomg(sv)) - goto oops_its_an_int; - else - SETn(-SvNV_nomg(sv)); + } + if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) + SETn(-SvNV_nomg(sv)); + else if (SvPOKp(sv) && SvIV_please_nomg(sv)) + goto oops_its_an_int; + else + SETn(-SvNV_nomg(sv)); } return NORMAL; } @@ -2575,14 +2575,14 @@ PP(pp_not) static void S_scomplement(pTHX_ SV *targ, SV *sv) { - U8 *tmps; - I32 anum; - STRLEN len; + U8 *tmps; + I32 anum; + STRLEN len; - sv_copypv_nomg(TARG, sv); - tmps = (U8*)SvPV_nomg(TARG, len); + sv_copypv_nomg(TARG, sv); + tmps = (U8*)SvPV_nomg(TARG, len); - if (SvUTF8(TARG)) { + if (SvUTF8(TARG)) { if (len && ! utf8_to_bytes(tmps, &len)) { Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]); } @@ -2590,20 +2590,20 @@ S_scomplement(pTHX_ SV *targ, SV *sv) SvUTF8_off(TARG); } - anum = len; + anum = len; - { - long *tmpl; - for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++) - *tmps = ~*tmps; - tmpl = (long*)tmps; - for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++) - *tmpl = ~*tmpl; - tmps = (U8*)tmpl; - } + { + long *tmpl; + for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++) + *tmps = ~*tmps; + tmpl = (long*)tmps; + for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++) + *tmpl = ~*tmpl; + tmps = (U8*)tmpl; + } - for ( ; anum > 0; anum--, tmps++) - *tmps = ~*tmps; + for ( ; anum > 0; anum--, tmps++) + *tmps = ~*tmps; } PP(pp_complement) @@ -2613,18 +2613,18 @@ PP(pp_complement) { dTOPss; if (SvNIOKp(sv)) { - if (PL_op->op_private & HINT_INTEGER) { - const IV i = ~SvIV_nomg(sv); - SETi(i); - } - else { - const UV u = ~SvUV_nomg(sv); - SETu(u); - } + if (PL_op->op_private & HINT_INTEGER) { + const IV i = ~SvIV_nomg(sv); + SETi(i); + } + else { + const UV u = ~SvUV_nomg(sv); + SETu(u); + } } else { - S_scomplement(aTHX_ TARG, sv); - SETTARG; + S_scomplement(aTHX_ TARG, sv); + SETTARG; } return NORMAL; } @@ -2635,15 +2635,15 @@ PP(pp_ncomplement) dSP; tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg); { - dTARGET; dTOPss; - if (PL_op->op_private & HINT_INTEGER) { - const IV i = ~SvIV_nomg(sv); - SETi(i); - } - else { - const UV u = ~SvUV_nomg(sv); - SETu(u); - } + dTARGET; dTOPss; + if (PL_op->op_private & HINT_INTEGER) { + const IV i = ~SvIV_nomg(sv); + SETi(i); + } + else { + const UV u = ~SvUV_nomg(sv); + SETu(u); + } } return NORMAL; } @@ -2653,10 +2653,10 @@ PP(pp_scomplement) dSP; tryAMAGICun_MG(scompl_amg, AMGf_numeric); { - dTARGET; dTOPss; - S_scomplement(aTHX_ TARG, sv); - SETTARG; - return NORMAL; + dTARGET; dTOPss; + S_scomplement(aTHX_ TARG, sv); + SETTARG; + return NORMAL; } } @@ -2682,7 +2682,7 @@ PP(pp_i_divide) dPOPTOPssrl; IV value = SvIV_nomg(right); if (value == 0) - DIE(aTHX_ "Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); num = SvIV_nomg(left); /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ @@ -2700,15 +2700,15 @@ PP(pp_i_modulo) dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % right ); - RETURN; + dPOPTOPiirl_nomg; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % right ); + RETURN; } } @@ -2809,11 +2809,11 @@ PP(pp_i_ncmp) I32 value; if (left > right) - value = 1; + value = 1; else if (left < right) - value = -1; + value = -1; else - value = 0; + value = 0; SETi(value); RETURN; } @@ -2825,10 +2825,10 @@ PP(pp_i_negate) tryAMAGICun_MG(neg_amg, 0); if (S_negate_string(aTHX)) return NORMAL; { - SV * const sv = TOPs; - IV const i = SvIV_nomg(sv); - SETi(-i); - return NORMAL; + SV * const sv = TOPs; + IV const i = SvIV_nomg(sv); + SETi(-i); + return NORMAL; } } @@ -2875,15 +2875,15 @@ PP(pp_sin) NV result = 0.0; #endif if (neg_report) { /* log or sqrt */ - if ( + if ( #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - ! Perl_isnan(value) && + ! Perl_isnan(value) && #endif - (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) { - SET_NUMERIC_STANDARD(); - /* diag_listed_as: Can't take log of %g */ - DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value); - } + (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) { + SET_NUMERIC_STANDARD(); + /* diag_listed_as: Can't take log of %g */ + DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value); + } } switch (op_type) { default: @@ -2912,39 +2912,39 @@ PP(pp_sin) PP(pp_rand) { if (!PL_srand_called) { - (void)seedDrand01((Rand_seed_t)seed()); - PL_srand_called = TRUE; + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; } { - dSP; - NV value; - - if (MAXARG < 1) - { - EXTEND(SP, 1); - value = 1.0; - } - else { - SV * const sv = POPs; - if(!sv) - value = 1.0; - else - value = SvNV(sv); - } + dSP; + NV value; + + if (MAXARG < 1) + { + EXTEND(SP, 1); + value = 1.0; + } + else { + SV * const sv = POPs; + if(!sv) + value = 1.0; + else + value = SvNV(sv); + } /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */ #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - if (! Perl_isnan(value) && value == 0.0) + if (! Perl_isnan(value) && value == 0.0) #else - if (value == 0.0) + if (value == 0.0) #endif - value = 1.0; - { - dTARGET; - PUSHs(TARG); - PUTBACK; - value *= Drand01(); - sv_setnv_mg(TARG, value); - } + value = 1.0; + { + dTARGET; + PUSHs(TARG); + PUTBACK; + value *= Drand01(); + sv_setnv_mg(TARG, value); + } } return NORMAL; } @@ -2977,12 +2977,12 @@ PP(pp_srand) (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; if (anum) - XPUSHu(anum); + XPUSHu(anum); else { - /* Historically srand always returned true. We can avoid breaking - that like this: */ - sv_setpvs(TARG, "0 but true"); - XPUSHTARG; + /* Historically srand always returned true. We can avoid breaking + that like this: */ + sv_setpvs(TARG, "0 but true"); + XPUSHTARG; } RETURN; } @@ -2995,37 +2995,37 @@ PP(pp_int) SV * const sv = TOPs; const IV iv = SvIV_nomg(sv); /* XXX it's arguable that compiler casting to IV might be subtly - different from modf (for numbers inside (IV_MIN,UV_MAX)) in which - else preferring IV has introduced a subtle behaviour change bug. OTOH - relying on floating point to be accurate is a bug. */ + different from modf (for numbers inside (IV_MIN,UV_MAX)) in which + else preferring IV has introduced a subtle behaviour change bug. OTOH + relying on floating point to be accurate is a bug. */ if (!SvOK(sv)) { SETu(0); } else if (SvIOK(sv)) { - if (SvIsUV(sv)) - SETu(SvUV_nomg(sv)); - else - SETi(iv); + if (SvIsUV(sv)) + SETu(SvUV_nomg(sv)); + else + SETi(iv); } else { - const NV value = SvNV_nomg(sv); - if (UNLIKELY(Perl_isinfnan(value))) - SETn(value); - else if (value >= 0.0) { - if (value < (NV)UV_MAX + 0.5) { - SETu(U_V(value)); - } else { - SETn(Perl_floor(value)); - } - } - else { - if (value > (NV)IV_MIN - 0.5) { - SETi(I_V(value)); - } else { - SETn(Perl_ceil(value)); - } - } + const NV value = SvNV_nomg(sv); + if (UNLIKELY(Perl_isinfnan(value))) + SETn(value); + else if (value >= 0.0) { + if (value < (NV)UV_MAX + 0.5) { + SETu(U_V(value)); + } else { + SETn(Perl_floor(value)); + } + } + else { + if (value > (NV)IV_MIN - 0.5) { + SETi(I_V(value)); + } else { + SETn(Perl_ceil(value)); + } + } } } return NORMAL; @@ -3044,28 +3044,28 @@ PP(pp_abs) SETu(0); } else if (SvIOK(sv)) { - /* IVX is precise */ - if (SvIsUV(sv)) { - SETu(SvUV_nomg(sv)); /* force it to be numeric only */ - } else { - if (iv >= 0) { - SETi(iv); - } else { - if (iv != IV_MIN) { - SETi(-iv); - } else { - /* 2s complement assumption. Also, not really needed as - IV_MIN and -IV_MIN should both be %100...00 and NV-able */ - SETu((UV)IV_MIN); - } - } - } + /* IVX is precise */ + if (SvIsUV(sv)) { + SETu(SvUV_nomg(sv)); /* force it to be numeric only */ + } else { + if (iv >= 0) { + SETi(iv); + } else { + if (iv != IV_MIN) { + SETi(-iv); + } else { + /* 2s complement assumption. Also, not really needed as + IV_MIN and -IV_MIN should both be %100...00 and NV-able */ + SETu((UV)IV_MIN); + } + } + } } else{ - const NV value = SvNV_nomg(sv); - if (value < 0.0) - SETn(-value); - else - SETn(value); + const NV value = SvNV_nomg(sv); + if (value < 0.0) + SETn(-value); + else + SETn(value); } } return NORMAL; @@ -3086,16 +3086,16 @@ PP(pp_oct) tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { - /* If Unicode, try to downgrade - * If not possible, croak. */ - SV* const tsv = sv_2mortal(newSVsv(sv)); + /* If Unicode, try to downgrade + * If not possible, croak. */ + SV* const tsv = sv_2mortal(newSVsv(sv)); - SvUTF8_on(tsv); - sv_utf8_downgrade(tsv, FALSE); - tmps = SvPV_const(tsv, len); + SvUTF8_on(tsv); + sv_utf8_downgrade(tsv, FALSE); + tmps = SvPV_const(tsv, len); } if (PL_op->op_type == OP_HEX) - goto hex; + goto hex; while (*tmps && len && isSPACE(*tmps)) tmps++, len--; @@ -3155,7 +3155,7 @@ PP(pp_length) if (SvOK(sv)) { STRLEN len; - if (!IN_BYTES) { /* reread to avoid using an C auto/register */ + if (!IN_BYTES) { /* reread to avoid using an C auto/register */ if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK) goto simple_pv; if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) { @@ -3163,9 +3163,9 @@ PP(pp_length) len = SvCUR(sv); goto return_bool; } - len = sv_len_utf8_nomg(sv); + len = sv_len_utf8_nomg(sv); } - else { + else { /* unrolled SvPV_nomg_const(sv,len) */ if (SvPOK_nog(sv)) { simple_pv: @@ -3179,15 +3179,15 @@ PP(pp_length) else { (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); } - } + } TARGi((IV)(len), 1); } else { - if (!SvPADTMP(TARG)) { + if (!SvPADTMP(TARG)) { /* OPpTARGET_MY: targ is var in '$lex = length()' */ sv_set_undef(TARG); SvSETMAGIC(TARG); - } + } else /* TARG is on stack at this point and is overwriten by SETs. * This branch is the odd one out, so put TARG by default on @@ -3204,9 +3204,9 @@ PP(pp_length) */ bool Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, - bool pos1_is_uv, IV len_iv, - bool len_is_uv, STRLEN *posp, - STRLEN *lenp) + bool pos1_is_uv, IV len_iv, + bool len_is_uv, STRLEN *posp, + STRLEN *lenp) { IV pos2_iv; int pos2_is_uv; @@ -3214,49 +3214,49 @@ Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; if (!pos1_is_uv && pos1_iv < 0 && curlen) { - pos1_is_uv = curlen-1 > ~(UV)pos1_iv; - pos1_iv += curlen; + pos1_is_uv = curlen-1 > ~(UV)pos1_iv; + pos1_iv += curlen; } if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen) - return FALSE; + return FALSE; if (len_iv || len_is_uv) { - if (!len_is_uv && len_iv < 0) { - pos2_iv = curlen + len_iv; - if (curlen) - pos2_is_uv = curlen-1 > ~(UV)len_iv; - else - pos2_is_uv = 0; - } else { /* len_iv >= 0 */ - if (!pos1_is_uv && pos1_iv < 0) { - pos2_iv = pos1_iv + len_iv; - pos2_is_uv = (UV)len_iv > (UV)IV_MAX; - } else { - if ((UV)len_iv > curlen-(UV)pos1_iv) - pos2_iv = curlen; - else - pos2_iv = pos1_iv+len_iv; - pos2_is_uv = 1; - } - } + if (!len_is_uv && len_iv < 0) { + pos2_iv = curlen + len_iv; + if (curlen) + pos2_is_uv = curlen-1 > ~(UV)len_iv; + else + pos2_is_uv = 0; + } else { /* len_iv >= 0 */ + if (!pos1_is_uv && pos1_iv < 0) { + pos2_iv = pos1_iv + len_iv; + pos2_is_uv = (UV)len_iv > (UV)IV_MAX; + } else { + if ((UV)len_iv > curlen-(UV)pos1_iv) + pos2_iv = curlen; + else + pos2_iv = pos1_iv+len_iv; + pos2_is_uv = 1; + } + } } else { - pos2_iv = curlen; - pos2_is_uv = 1; + pos2_iv = curlen; + pos2_is_uv = 1; } if (!pos2_is_uv && pos2_iv < 0) { - if (!pos1_is_uv && pos1_iv < 0) - return FALSE; - pos2_iv = 0; + if (!pos1_is_uv && pos1_iv < 0) + return FALSE; + pos2_iv = 0; } else if (!pos1_is_uv && pos1_iv < 0) - pos1_iv = 0; + pos1_iv = 0; if ((UV)pos2_iv < (UV)pos1_iv) - pos2_iv = pos1_iv; + pos2_iv = pos1_iv; if ((UV)pos2_iv > curlen) - pos2_iv = curlen; + pos2_iv = curlen; /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */ *posp = (STRLEN)( (UV)pos1_iv ); @@ -3287,120 +3287,120 @@ PP(pp_substr) bool repl_need_utf8_upgrade = FALSE; if (num_args > 2) { - if (num_args > 3) { - if(!(repl_sv = POPs)) num_args--; - } - if ((len_sv = POPs)) { - len_iv = SvIV(len_sv); - len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1; - } - else num_args--; + if (num_args > 3) { + if(!(repl_sv = POPs)) num_args--; + } + if ((len_sv = POPs)) { + len_iv = SvIV(len_sv); + len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1; + } + else num_args--; } pos_sv = POPs; pos1_iv = SvIV(pos_sv); pos1_is_uv = SvIOK_UV(pos_sv); sv = POPs; if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) { - assert(!repl_sv); - repl_sv = POPs; + assert(!repl_sv); + repl_sv = POPs; } if (lvalue && !repl_sv) { - SV * ret; - ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ - sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); - LvTYPE(ret) = 'x'; - LvTARG(ret) = SvREFCNT_inc_simple(sv); - LvTARGOFF(ret) = - pos1_is_uv || pos1_iv >= 0 - ? (STRLEN)(UV)pos1_iv - : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv); - LvTARGLEN(ret) = - len_is_uv || len_iv > 0 - ? (STRLEN)(UV)len_iv - : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv); - - PUSHs(ret); /* avoid SvSETMAGIC here */ - RETURN; + SV * ret; + ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); + LvTYPE(ret) = 'x'; + LvTARG(ret) = SvREFCNT_inc_simple(sv); + LvTARGOFF(ret) = + pos1_is_uv || pos1_iv >= 0 + ? (STRLEN)(UV)pos1_iv + : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv); + LvTARGLEN(ret) = + len_is_uv || len_iv > 0 + ? (STRLEN)(UV)len_iv + : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv); + + PUSHs(ret); /* avoid SvSETMAGIC here */ + RETURN; } if (repl_sv) { - repl = SvPV_const(repl_sv, repl_len); - SvGETMAGIC(sv); - if (SvROK(sv)) - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr" - ); - tmps = SvPV_force_nomg(sv, curlen); - if (DO_UTF8(repl_sv) && repl_len) { - if (!DO_UTF8(sv)) { + repl = SvPV_const(repl_sv, repl_len); + SvGETMAGIC(sv); + if (SvROK(sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr" + ); + tmps = SvPV_force_nomg(sv, curlen); + if (DO_UTF8(repl_sv) && repl_len) { + if (!DO_UTF8(sv)) { /* Upgrade the dest, and recalculate tmps in case the buffer * got reallocated; curlen may also have been changed */ - sv_utf8_upgrade_nomg(sv); - tmps = SvPV_nomg(sv, curlen); - } - } - else if (DO_UTF8(sv)) - repl_need_utf8_upgrade = TRUE; + sv_utf8_upgrade_nomg(sv); + tmps = SvPV_nomg(sv, curlen); + } + } + else if (DO_UTF8(sv)) + repl_need_utf8_upgrade = TRUE; } else tmps = SvPV_const(sv, curlen); if (DO_UTF8(sv)) { utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen); - if (utf8_curlen == curlen) - utf8_curlen = 0; - else - curlen = utf8_curlen; + if (utf8_curlen == curlen) + utf8_curlen = 0; + else + curlen = utf8_curlen; } else - utf8_curlen = 0; + utf8_curlen = 0; { - STRLEN pos, len, byte_len, byte_pos; + STRLEN pos, len, byte_len, byte_pos; - if (!translate_substr_offsets( - curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len - )) goto bound_fail; + if (!translate_substr_offsets( + curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len + )) goto bound_fail; - byte_len = len; - byte_pos = utf8_curlen - ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos; + byte_len = len; + byte_pos = utf8_curlen + ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos; - tmps += byte_pos; + tmps += byte_pos; - if (rvalue) { - SvTAINTED_off(TARG); /* decontaminate */ - SvUTF8_off(TARG); /* decontaminate */ - sv_setpvn(TARG, tmps, byte_len); + if (rvalue) { + SvTAINTED_off(TARG); /* decontaminate */ + SvUTF8_off(TARG); /* decontaminate */ + sv_setpvn(TARG, tmps, byte_len); #ifdef USE_LOCALE_COLLATE - sv_unmagic(TARG, PERL_MAGIC_collxfrm); + sv_unmagic(TARG, PERL_MAGIC_collxfrm); #endif - if (utf8_curlen) - SvUTF8_on(TARG); - } - - if (repl) { - SV* repl_sv_copy = NULL; - - if (repl_need_utf8_upgrade) { - repl_sv_copy = newSVsv(repl_sv); - sv_utf8_upgrade(repl_sv_copy); - repl = SvPV_const(repl_sv_copy, repl_len); - } - if (!SvOK(sv)) - SvPVCLEAR(sv); - sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0); - SvREFCNT_dec(repl_sv_copy); - } - } - if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) - SP++; + if (utf8_curlen) + SvUTF8_on(TARG); + } + + if (repl) { + SV* repl_sv_copy = NULL; + + if (repl_need_utf8_upgrade) { + repl_sv_copy = newSVsv(repl_sv); + sv_utf8_upgrade(repl_sv_copy); + repl = SvPV_const(repl_sv_copy, repl_len); + } + if (!SvOK(sv)) + SvPVCLEAR(sv); + sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0); + SvREFCNT_dec(repl_sv_copy); + } + } + if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) + SP++; else if (rvalue) { - SvSETMAGIC(TARG); - PUSHs(TARG); + SvSETMAGIC(TARG); + PUSHs(TARG); } RETURN; bound_fail: if (repl) - Perl_croak(aTHX_ "substr outside of string"); + Perl_croak(aTHX_ "substr outside of string"); Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); RETPUSHUNDEF; } @@ -3438,23 +3438,23 @@ PP(pp_vec) retuv = errflags ? 0 : do_vecget(src, offset, size); if (lvalue) { /* it's an lvalue! */ - ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ - sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); - LvTYPE(ret) = 'v'; - LvTARG(ret) = SvREFCNT_inc_simple(src); - LvTARGOFF(ret) = offset; - LvTARGLEN(ret) = size; - LvFLAGS(ret) = errflags; + ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); + LvTYPE(ret) = 'v'; + LvTARG(ret) = SvREFCNT_inc_simple(src); + LvTARGOFF(ret) = offset; + LvTARGLEN(ret) = size; + LvFLAGS(ret) = errflags; } else { - dTARGET; - SvTAINTED_off(TARG); /* decontaminate */ - ret = TARG; + dTARGET; + SvTAINTED_off(TARG); /* decontaminate */ + ret = TARG; } sv_setuv(ret, retuv); if (!lvalue) - SvSETMAGIC(ret); + SvSETMAGIC(ret); PUSHs(ret); RETURN; } @@ -3480,7 +3480,7 @@ PP(pp_index) const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); if (threeargs) - offset = POPi; + offset = POPi; little = POPs; big = POPs; big_p = SvPV_const(big, biglen); @@ -3489,78 +3489,78 @@ PP(pp_index) big_utf8 = DO_UTF8(big); little_utf8 = DO_UTF8(little); if (big_utf8 ^ little_utf8) { - /* One needs to be upgraded. */ - if (little_utf8) { - /* Well, maybe instead we might be able to downgrade the small - string? */ - char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, - &little_utf8); - if (little_utf8) { - /* If the large string is ISO-8859-1, and it's not possible to - convert the small string to ISO-8859-1, then there is no - way that it could be found anywhere by index. */ - retval = -1; - goto push_result; - } - - /* At this point, pv is a malloc()ed string. So donate it to temp - to ensure it will get free()d */ - little = temp = newSV(0); - sv_usepvn(temp, pv, llen); - little_p = SvPVX(little); - } else { - temp = newSVpvn(little_p, llen); - - sv_utf8_upgrade(temp); - little = temp; - little_p = SvPV_const(little, llen); - } + /* One needs to be upgraded. */ + if (little_utf8) { + /* Well, maybe instead we might be able to downgrade the small + string? */ + char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, + &little_utf8); + if (little_utf8) { + /* If the large string is ISO-8859-1, and it's not possible to + convert the small string to ISO-8859-1, then there is no + way that it could be found anywhere by index. */ + retval = -1; + goto push_result; + } + + /* At this point, pv is a malloc()ed string. So donate it to temp + to ensure it will get free()d */ + little = temp = newSV(0); + sv_usepvn(temp, pv, llen); + little_p = SvPVX(little); + } else { + temp = newSVpvn(little_p, llen); + + sv_utf8_upgrade(temp); + little = temp; + little_p = SvPV_const(little, llen); + } } if (SvGAMAGIC(big)) { - /* Life just becomes a lot easier if I use a temporary here. - Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) - will trigger magic and overloading again, as will fbm_instr() - */ - big = newSVpvn_flags(big_p, biglen, - SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); - big_p = SvPVX(big); + /* Life just becomes a lot easier if I use a temporary here. + Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) + will trigger magic and overloading again, as will fbm_instr() + */ + big = newSVpvn_flags(big_p, biglen, + SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); + big_p = SvPVX(big); } if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { - /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will - warn on undef, and we've already triggered a warning with the - SvPV_const some lines above. We can't remove that, as we need to - call some SvPV to trigger overloading early and find out if the - string is UTF-8. - This is all getting too messy. The API isn't quite clean enough, - because data access has side effects. - */ - little = newSVpvn_flags(little_p, llen, - SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); - little_p = SvPVX(little); + /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will + warn on undef, and we've already triggered a warning with the + SvPV_const some lines above. We can't remove that, as we need to + call some SvPV to trigger overloading early and find out if the + string is UTF-8. + This is all getting too messy. The API isn't quite clean enough, + because data access has side effects. + */ + little = newSVpvn_flags(little_p, llen, + SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); + little_p = SvPVX(little); } if (!threeargs) - offset = is_index ? 0 : biglen; + offset = is_index ? 0 : biglen; else { - if (big_utf8 && offset > 0) - offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); - if (!is_index) - offset += llen; + if (big_utf8 && offset > 0) + offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); + if (!is_index) + offset += llen; } if (offset < 0) - offset = 0; + offset = 0; else if (offset > (SSize_t)biglen) - offset = biglen; + offset = biglen; if (!(little_p = is_index - ? fbm_instr((unsigned char*)big_p + offset, - (unsigned char*)big_p + biglen, little, 0) - : rninstr(big_p, big_p + offset, - little_p, little_p + llen))) - retval = -1; + ? fbm_instr((unsigned char*)big_p + offset, + (unsigned char*)big_p + biglen, little, 0) + : rninstr(big_p, big_p + offset, + little_p, little_p + llen))) + retval = -1; else { - retval = little_p - big_p; - if (retval > 1 && big_utf8) - retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); + retval = little_p - big_p; + if (retval > 1 && big_utf8) + retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); } SvREFCNT_dec(temp); @@ -3618,7 +3618,7 @@ PP(pp_chr) SvGETMAGIC(top); if (UNLIKELY(SvAMAGIC(top))) - top = sv_2num(top); + top = sv_2num(top); if (UNLIKELY(isinfnansv(top))) Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top)); else { @@ -3628,12 +3628,12 @@ PP(pp_chr) ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) && SvNV_nomg(top) < 0.0))) { - if (ckWARN(WARN_UTF8)) { - if (SvGMAGICAL(top)) { - SV *top2 = sv_newmortal(); - sv_setsv_nomg(top2, top); - top = top2; - } + if (ckWARN(WARN_UTF8)) { + if (SvGMAGICAL(top)) { + SV *top2 = sv_newmortal(); + sv_setsv_nomg(top2, top); + top = top2; + } Perl_warner(aTHX_ packWARN(WARN_UTF8), "Invalid negative number (%" SVf ") in chr", SVfARG(top)); } @@ -3646,14 +3646,14 @@ PP(pp_chr) SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { - SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); - tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); - SvCUR_set(TARG, tmps - SvPVX_const(TARG)); - *tmps = '\0'; - (void)SvPOK_only(TARG); - SvUTF8_on(TARG); - SETTARG; - return NORMAL; + SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); + tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); + SvCUR_set(TARG, tmps - SvPVX_const(TARG)); + *tmps = '\0'; + (void)SvPOK_only(TARG); + SvUTF8_on(TARG); + SETTARG; + return NORMAL; } SvGROW(TARG,2); @@ -3677,12 +3677,12 @@ PP(pp_crypt) if (DO_UTF8(left)) { /* If Unicode, try to downgrade. - * If not possible, croak. - * Yes, we made this up. */ - SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); + * If not possible, croak. + * Yes, we made this up. */ + SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); - sv_utf8_downgrade(tsv, FALSE); - tmps = SvPV_const(tsv, len); + sv_utf8_downgrade(tsv, FALSE); + tmps = SvPV_const(tsv, len); } # ifdef USE_ITHREADS # ifdef HAS_CRYPT_R @@ -3691,11 +3691,11 @@ PP(pp_crypt) * one thread per interpreter. If this would not be true, * we would need a mutex to protect this malloc. */ PL_reentrant_buffer->_crypt_struct_buffer = - (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); + (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); # if defined(__GLIBC__) || defined(__EMX__) - if (PL_reentrant_buffer->_crypt_struct_buffer) { - PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; - } + if (PL_reentrant_buffer->_crypt_struct_buffer) { + PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; + } # endif } # endif /* HAS_CRYPT_R */ @@ -3738,10 +3738,10 @@ PP(pp_ucfirst) U8 *d; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN ulen; /* ulen is the byte length of the original Unicode character - * stored as UTF-8 at s. */ + * stored as UTF-8 at s. */ STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or - * lowercased) character stored in tmpbuf. May be either - * UTF-8 or not, but in either case is the number of bytes */ + * lowercased) character stored in tmpbuf. May be either + * UTF-8 or not, but in either case is the number of bytes */ bool remove_dot_above = FALSE; s = (const U8*)SvPV_const(source, slen); @@ -3764,26 +3764,26 @@ PP(pp_ucfirst) * or even if have to convert the dest to UTF-8 when the source isn't */ if (! slen) { /* If empty */ - need = 1; /* still need a trailing NUL */ - ulen = 0; + need = 1; /* still need a trailing NUL */ + ulen = 0; *tmpbuf = '\0'; } else if (DO_UTF8(source)) { /* Is the source utf8? */ - doing_utf8 = TRUE; + doing_utf8 = TRUE; ulen = UTF8SKIP(s); if (op_type == OP_UCFIRST) { #ifdef USE_LOCALE_CTYPE - _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); + _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); #else - _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0); + _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0); #endif - } + } else { #ifdef USE_LOCALE_CTYPE - _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); + _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); /* In turkic locales, lower casing an 'I' normally yields U+0131, * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also @@ -3815,7 +3815,7 @@ PP(pp_ucfirst) #else PERL_UNUSED_VAR(remove_dot_above); - _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0); + _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0); #endif } @@ -3825,12 +3825,12 @@ PP(pp_ucfirst) need = slen + 1 - ulen + tculen; } else { /* Non-zero length, non-UTF-8, Need to consider locale and if - * latin1 is treated as caseless. Note that a locale takes - * precedence */ - ulen = 1; /* Original character is 1 byte */ - tculen = 1; /* Most characters will require one byte, but this will - * need to be overridden for the tricky ones */ - need = slen + 1; + * latin1 is treated as caseless. Note that a locale takes + * precedence */ + ulen = 1; /* Original character is 1 byte */ + tculen = 1; /* Most characters will require one byte, but this will + * need to be overridden for the tricky ones */ + need = slen + 1; #ifdef USE_LOCALE_CTYPE @@ -3889,85 +3889,85 @@ PP(pp_ucfirst) /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is * non-turkic UTF-8, which we treat as not in locale), and cased * latin1 */ - UV title_ord; + UV title_ord; #ifdef USE_LOCALE_CTYPE do_uni_rules: #endif - title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); - if (tculen > 1) { - assert(tculen == 2); + title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); + if (tculen > 1) { + assert(tculen == 2); /* If the result is an upper Latin1-range character, it can * still be represented in one byte, which is its ordinal */ - if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) { - *tmpbuf = (U8) title_ord; - tculen = 1; - } - else { + if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) { + *tmpbuf = (U8) title_ord; + tculen = 1; + } + else { /* Otherwise it became more than one ASCII character (in * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to * beyond Latin1, so the number of bytes changed, so can't * replace just the first character in place. */ - inplace = FALSE; + inplace = FALSE; /* If the result won't fit in a byte, the entire result * will have to be in UTF-8. Allocate enough space for the * expanded first byte, and if UTF-8, the rest of the input * string, some or all of which may also expand to two * bytes, plus the terminating NUL. */ - if (title_ord > 255) { - doing_utf8 = TRUE; - convert_source_to_utf8 = TRUE; - need = slen + if (title_ord > 255) { + doing_utf8 = TRUE; + convert_source_to_utf8 = TRUE; + need = slen + variant_under_utf8_count(s, s + slen) + 1; /* The (converted) UTF-8 and UTF-EBCDIC lengths of all * characters whose title case is above 255 is * 2. */ - ulen = 2; - } + ulen = 2; + } else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */ - need = slen + 1 + 1; - } - } - } - } /* End of use Unicode (Latin1) semantics */ + need = slen + 1 + 1; + } + } + } + } /* End of use Unicode (Latin1) semantics */ } /* End of changing the case of the first character */ /* Here, have the first character's changed case stored in tmpbuf. Ready to * generate the result */ if (inplace) { - /* We can convert in place. This means we change just the first - * character without disturbing the rest; no need to grow */ - dest = source; - s = d = (U8*)SvPV_force_nomg(source, slen); + /* We can convert in place. This means we change just the first + * character without disturbing the rest; no need to grow */ + dest = source; + s = d = (U8*)SvPV_force_nomg(source, slen); } else { - dTARGET; + dTARGET; - dest = TARG; + dest = TARG; - /* Here, we can't convert in place; we earlier calculated how much - * space we will need, so grow to accommodate that */ - SvUPGRADE(dest, SVt_PV); - d = (U8*)SvGROW(dest, need); - (void)SvPOK_only(dest); + /* Here, we can't convert in place; we earlier calculated how much + * space we will need, so grow to accommodate that */ + SvUPGRADE(dest, SVt_PV); + d = (U8*)SvGROW(dest, need); + (void)SvPOK_only(dest); - SETs(dest); + SETs(dest); } if (doing_utf8) { - if (! inplace) { - if (! convert_source_to_utf8) { + if (! inplace) { + if (! convert_source_to_utf8) { - /* Here both source and dest are in UTF-8, but have to create - * the entire output. We initialize the result to be the - * title/lower cased first character, and then append the rest - * of the string. */ - sv_setpvn(dest, (char*)tmpbuf, tculen); - if (slen > ulen) { + /* Here both source and dest are in UTF-8, but have to create + * the entire output. We initialize the result to be the + * title/lower cased first character, and then append the rest + * of the string. */ + sv_setpvn(dest, (char*)tmpbuf, tculen); + if (slen > ulen) { /* But this boolean being set means we are in a turkic * locale, and there is a DOT character that needs to be @@ -3991,68 +3991,68 @@ PP(pp_ucfirst) /* The rest of the string can be concatenated unchanged, * all at once */ - sv_catpvn(dest, (char*)(s + ulen), slen - ulen); - } - } - else { - const U8 *const send = s + slen; - - /* Here the dest needs to be in UTF-8, but the source isn't, - * except we earlier UTF-8'd the first character of the source - * into tmpbuf. First put that into dest, and then append the - * rest of the source, converting it to UTF-8 as we go. */ - - /* Assert tculen is 2 here because the only characters that - * get to this part of the code have 2-byte UTF-8 equivalents */ + sv_catpvn(dest, (char*)(s + ulen), slen - ulen); + } + } + else { + const U8 *const send = s + slen; + + /* Here the dest needs to be in UTF-8, but the source isn't, + * except we earlier UTF-8'd the first character of the source + * into tmpbuf. First put that into dest, and then append the + * rest of the source, converting it to UTF-8 as we go. */ + + /* Assert tculen is 2 here because the only characters that + * get to this part of the code have 2-byte UTF-8 equivalents */ assert(tculen == 2); - *d++ = *tmpbuf; - *d++ = *(tmpbuf + 1); - s++; /* We have just processed the 1st char */ + *d++ = *tmpbuf; + *d++ = *(tmpbuf + 1); + s++; /* We have just processed the 1st char */ while (s < send) { append_utf8_from_native_byte(*s, &d); s++; } - *d = '\0'; - SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } - SvUTF8_on(dest); - } - else { /* in-place UTF-8. Just overwrite the first character */ - Copy(tmpbuf, d, tculen, U8); - SvCUR_set(dest, need - 1); - } + *d = '\0'; + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + } + SvUTF8_on(dest); + } + else { /* in-place UTF-8. Just overwrite the first character */ + Copy(tmpbuf, d, tculen, U8); + SvCUR_set(dest, need - 1); + } } else { /* Neither source nor dest are, nor need to be UTF-8 */ - if (slen) { - if (inplace) { /* in-place, only need to change the 1st char */ - *d = *tmpbuf; - } - else { /* Not in-place */ - - /* Copy the case-changed character(s) from tmpbuf */ - Copy(tmpbuf, d, tculen, U8); - d += tculen - 1; /* Code below expects d to point to final - * character stored */ - } - } - else { /* empty source */ - /* See bug #39028: Don't taint if empty */ - *d = *s; - } - - /* In a "use bytes" we don't treat the source as UTF-8, but, still want - * the destination to retain that flag */ - if (DO_UTF8(source)) - SvUTF8_on(dest); - - if (!inplace) { /* Finish the rest of the string, unchanged */ - /* This will copy the trailing NUL */ - Copy(s + 1, d + 1, slen, U8); - SvCUR_set(dest, need - 1); - } + if (slen) { + if (inplace) { /* in-place, only need to change the 1st char */ + *d = *tmpbuf; + } + else { /* Not in-place */ + + /* Copy the case-changed character(s) from tmpbuf */ + Copy(tmpbuf, d, tculen, U8); + d += tculen - 1; /* Code below expects d to point to final + * character stored */ + } + } + else { /* empty source */ + /* See bug #39028: Don't taint if empty */ + *d = *s; + } + + /* In a "use bytes" we don't treat the source as UTF-8, but, still want + * the destination to retain that flag */ + if (DO_UTF8(source)) + SvUTF8_on(dest); + + if (!inplace) { /* Finish the rest of the string, unchanged */ + /* This will copy the trailing NUL */ + Copy(s + 1, d + 1, slen, U8); + SvCUR_set(dest, need - 1); + } } #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { @@ -4061,7 +4061,7 @@ PP(pp_ucfirst) } #endif if (dest != source && SvTAINTED(source)) - SvTAINT(dest); + SvTAINT(dest); SvSETMAGIC(dest); return NORMAL; } @@ -4079,9 +4079,9 @@ PP(pp_uc) SvGETMAGIC(source); if ( SvPADTMP(source) - && !SvREADONLY(source) && SvPOK(source) - && !DO_UTF8(source) - && ( + && !SvREADONLY(source) && SvPOK(source) + && !DO_UTF8(source) + && ( #ifdef USE_LOCALE_CTYPE (IN_LC_RUNTIME(LC_CTYPE)) ? ! IN_UTF8_CTYPE_LOCALE @@ -4099,22 +4099,22 @@ PP(pp_uc) * that latter becomes irrelevant in the above test; instead for * locale, the size can't normally change, except if the locale is a * UTF-8 one */ - dest = source; - s = d = (U8*)SvPV_force_nomg(source, len); - min = len + 1; + dest = source; + s = d = (U8*)SvPV_force_nomg(source, len); + min = len + 1; } else { - dTARGET; + dTARGET; - dest = TARG; + dest = TARG; - s = (const U8*)SvPV_nomg_const(source, len); - min = len + 1; + s = (const U8*)SvPV_nomg_const(source, len); + min = len + 1; - SvUPGRADE(dest, SVt_PV); - d = (U8*)SvGROW(dest, min); - (void)SvPOK_only(dest); + SvUPGRADE(dest, SVt_PV); + d = (U8*)SvGROW(dest, min); + (void)SvPOK_only(dest); - SETs(dest); + SETs(dest); } #ifdef USE_LOCALE_CTYPE @@ -4129,28 +4129,28 @@ PP(pp_uc) to check DO_UTF8 again here. */ if (DO_UTF8(source)) { - const U8 *const send = s + len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; + const U8 *const send = s + len; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; #define GREEK_CAPITAL_LETTER_IOTA 0x0399 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 - /* All occurrences of these are to be moved to follow any other marks. - * This is context-dependent. We may not be passed enough context to - * move the iota subscript beyond all of them, but we do the best we can - * with what we're given. The result is always better than if we - * hadn't done this. And, the problem would only arise if we are - * passed a character without all its combining marks, which would be - * the caller's mistake. The information this is based on comes from a - * comment in Unicode SpecialCasing.txt, (and the Standard's text - * itself) and so can't be checked properly to see if it ever gets - * revised. But the likelihood of it changing is remote */ - bool in_iota_subscript = FALSE; - - while (s < send) { - STRLEN u; - STRLEN ulen; - UV uv; - if (UNLIKELY(in_iota_subscript)) { + /* All occurrences of these are to be moved to follow any other marks. + * This is context-dependent. We may not be passed enough context to + * move the iota subscript beyond all of them, but we do the best we can + * with what we're given. The result is always better than if we + * hadn't done this. And, the problem would only arise if we are + * passed a character without all its combining marks, which would be + * the caller's mistake. The information this is based on comes from a + * comment in Unicode SpecialCasing.txt, (and the Standard's text + * itself) and so can't be checked properly to see if it ever gets + * revised. But the likelihood of it changing is remote */ + bool in_iota_subscript = FALSE; + + while (s < send) { + STRLEN u; + STRLEN ulen; + UV uv; + if (UNLIKELY(in_iota_subscript)) { UV cp = utf8_to_uvchr_buf(s, send, NULL); if (! _invlist_contains_cp(PL_utf8_mark, cp)) { @@ -4194,47 +4194,47 @@ PP(pp_uc) d += ulen; } s += u; - } - if (in_iota_subscript) { + } + if (in_iota_subscript) { *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA); *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA); - } - SvUTF8_on(dest); - *d = '\0'; + } + SvUTF8_on(dest); + *d = '\0'; - SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); } else { /* Not UTF-8 */ - if (len) { - const U8 *const send = s + len; + if (len) { + const U8 *const send = s + len; - /* Use locale casing if in locale; regular style if not treating - * latin1 as having case; otherwise the latin1 casing. Do the - * whole thing in a tight loop, for speed, */ + /* Use locale casing if in locale; regular style if not treating + * latin1 as having case; otherwise the latin1 casing. Do the + * whole thing in a tight loop, for speed, */ #ifdef USE_LOCALE_CTYPE - if (IN_LC_RUNTIME(LC_CTYPE)) { + if (IN_LC_RUNTIME(LC_CTYPE)) { if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } - for (; s < send; d++, s++) + for (; s < send; d++, s++) *d = (U8) toUPPER_LC(*s); - } - else + } + else #endif if (! IN_UNI_8_BIT) { - for (; s < send; d++, s++) { - *d = toUPPER(*s); - } - } - else { + for (; s < send; d++, s++) { + *d = toUPPER(*s); + } + } + else { #ifdef USE_LOCALE_CTYPE do_uni_rules: #endif - for (; s < send; d++, s++) { + for (; s < send; d++, s++) { Size_t extra; - *d = toUPPER_LATIN1_MOD(*s); - if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) + *d = toUPPER_LATIN1_MOD(*s); + if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) #ifdef USE_LOCALE_CTYPE @@ -4247,7 +4247,7 @@ PP(pp_uc) continue; } - /* The mainstream case is the tight loop above. To avoid + /* The mainstream case is the tight loop above. To avoid * extra tests in that, all three characters that always * require special handling are mapped by the MOD to the * one tested just above. Use the source to distinguish @@ -4256,22 +4256,22 @@ PP(pp_uc) #if UNICODE_MAJOR_VERSION > 2 \ || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ && UNICODE_DOT_DOT_VERSION >= 8) - if (*s == LATIN_SMALL_LETTER_SHARP_S) { - - /* uc() of this requires 2 characters, but they are - * ASCII. If not enough room, grow the string */ - if (SvLEN(dest) < ++min) { - const UV o = d - (U8*)SvPVX_const(dest); - d = o + (U8*) SvGROW(dest, min); - } - *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ - continue; /* Back to the tight loop; still in ASCII */ - } + if (*s == LATIN_SMALL_LETTER_SHARP_S) { + + /* uc() of this requires 2 characters, but they are + * ASCII. If not enough room, grow the string */ + if (SvLEN(dest) < ++min) { + const UV o = d - (U8*)SvPVX_const(dest); + d = o + (U8*) SvGROW(dest, min); + } + *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ + continue; /* Back to the tight loop; still in ASCII */ + } #endif - /* The other special handling characters have their - * upper cases outside the latin1 range, hence need to be - * in UTF-8, so the whole result needs to be in UTF-8. + /* The other special handling characters have their + * upper cases outside the latin1 range, hence need to be + * in UTF-8, so the whole result needs to be in UTF-8. * * So, here we are somewhere in the middle of processing a * non-UTF-8 string, and realize that we will have to @@ -4322,19 +4322,19 @@ PP(pp_uc) #endif /* Convert what we have so far into UTF-8, telling the - * function that we know it should be converted, and to - * allow extra space for what we haven't processed yet. + * function that we know it should be converted, and to + * allow extra space for what we haven't processed yet. * * This may cause the string pointer to move, so need to * save and re-find it. */ - len = d - (U8*)SvPVX_const(dest); - SvCUR_set(dest, len); - len = sv_utf8_upgrade_flags_grow(dest, - SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + len = d - (U8*)SvPVX_const(dest); + SvCUR_set(dest, len); + len = sv_utf8_upgrade_flags_grow(dest, + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, extra + 1 /* trailing NUL */ ); - d = (U8*)SvPVX(dest) + len; + d = (U8*)SvPVX(dest) + len; /* Now process the remainder of the source, simultaneously * converting to upper and UTF-8. @@ -4368,15 +4368,15 @@ PP(pp_uc) /* Here have processed the whole source; no need to * continue with the outer loop. Each character has been * converted to upper case and converted to UTF-8. */ - break; - } /* End of processing all latin1-style chars */ - } /* End of processing all chars */ - } /* End of source is not empty */ - - if (source != dest) { - *d = '\0'; /* Here d points to 1 after last char, add NUL */ - SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } + break; + } /* End of processing all latin1-style chars */ + } /* End of processing all chars */ + } /* End of source is not empty */ + + if (source != dest) { + *d = '\0'; /* Here d points to 1 after last char, add NUL */ + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + } } /* End of isn't utf8 */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { @@ -4385,7 +4385,7 @@ PP(pp_uc) } #endif if (dest != source && SvTAINTED(source)) - SvTAINT(dest); + SvTAINT(dest); SvSETMAGIC(dest); return NORMAL; } @@ -4404,8 +4404,8 @@ PP(pp_lc) SvGETMAGIC(source); if ( SvPADTMP(source) - && !SvREADONLY(source) && SvPOK(source) - && !DO_UTF8(source) + && !SvREADONLY(source) && SvPOK(source) + && !DO_UTF8(source) #ifdef USE_LOCALE_CTYPE @@ -4419,22 +4419,22 @@ PP(pp_lc) /* We can convert in place, as, outside of Turkic UTF-8 locales, * lowercasing anything in the latin1 range (or else DO_UTF8 would have * been on) doesn't lengthen it. */ - dest = source; - s = d = (U8*)SvPV_force_nomg(source, len); - min = len + 1; + dest = source; + s = d = (U8*)SvPV_force_nomg(source, len); + min = len + 1; } else { - dTARGET; + dTARGET; - dest = TARG; + dest = TARG; - s = (const U8*)SvPV_nomg_const(source, len); - min = len + 1; + s = (const U8*)SvPV_nomg_const(source, len); + min = len + 1; - SvUPGRADE(dest, SVt_PV); - d = (U8*)SvGROW(dest, min); - (void)SvPOK_only(dest); + SvUPGRADE(dest, SVt_PV); + d = (U8*)SvGROW(dest, min); + (void)SvPOK_only(dest); - SETs(dest); + SETs(dest); } #ifdef USE_LOCALE_CTYPE @@ -4482,17 +4482,17 @@ PP(pp_lc) to check DO_UTF8 again here. */ if (DO_UTF8(source)) { - const U8 *const send = s + len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; + const U8 *const send = s + len; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; bool remove_dot_above = FALSE; - while (s < send) { - const STRLEN u = UTF8SKIP(s); - STRLEN ulen; + while (s < send) { + const STRLEN u = UTF8SKIP(s); + STRLEN ulen; #ifdef USE_LOCALE_CTYPE - _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); + _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); /* If we are in a Turkic locale, we have to do more work. As noted * in the comments for lcfirst, there is a special case if a 'I' @@ -4520,44 +4520,44 @@ PP(pp_lc) #else PERL_UNUSED_VAR(remove_dot_above); - _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0); + _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0); #endif /* Here is where we would do context-sensitive actions for the * Greek final sigma. See the commit message for 86510fb15 for why * there isn't any */ - if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { - - /* If the eventually required minimum size outgrows the - * available space, we need to grow. */ - const UV o = d - (U8*)SvPVX_const(dest); - - /* If someone lowercases one million U+0130s we SvGROW() one - * million times. Or we could try guessing how much to - * allocate without allocating too much. Such is life. - * Another option would be to grow an extra byte or two more - * each time we need to grow, which would cut down the million - * to 500K, with little waste */ - d = o + (U8*) SvGROW(dest, min); - } - - /* Copy the newly lowercased letter to the output buffer we're - * building */ - Copy(tmpbuf, d, ulen, U8); - d += ulen; - s += u; - } /* End of looping through the source string */ - SvUTF8_on(dest); - *d = '\0'; - SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { + + /* If the eventually required minimum size outgrows the + * available space, we need to grow. */ + const UV o = d - (U8*)SvPVX_const(dest); + + /* If someone lowercases one million U+0130s we SvGROW() one + * million times. Or we could try guessing how much to + * allocate without allocating too much. Such is life. + * Another option would be to grow an extra byte or two more + * each time we need to grow, which would cut down the million + * to 500K, with little waste */ + d = o + (U8*) SvGROW(dest, min); + } + + /* Copy the newly lowercased letter to the output buffer we're + * building */ + Copy(tmpbuf, d, ulen, U8); + d += ulen; + s += u; + } /* End of looping through the source string */ + SvUTF8_on(dest); + *d = '\0'; + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); } else { /* 'source' not utf8 */ - if (len) { - const U8 *const send = s + len; + if (len) { + const U8 *const send = s + len; - /* Use locale casing if in locale; regular style if not treating - * latin1 as having case; otherwise the latin1 casing. Do the - * whole thing in a tight loop, for speed, */ + /* Use locale casing if in locale; regular style if not treating + * latin1 as having case; otherwise the latin1 casing. Do the + * whole thing in a tight loop, for speed, */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { if (LIKELY( ! has_turkic_I)) { @@ -4577,23 +4577,23 @@ PP(pp_lc) } } } - else + else #endif if (! IN_UNI_8_BIT) { - for (; s < send; d++, s++) { - *d = toLOWER(*s); - } - } - else { - for (; s < send; d++, s++) { - *d = toLOWER_LATIN1(*s); - } - } - } - if (source != dest) { - *d = '\0'; - SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } + for (; s < send; d++, s++) { + *d = toLOWER(*s); + } + } + else { + for (; s < send; d++, s++) { + *d = toLOWER_LATIN1(*s); + } + } + } + if (source != dest) { + *d = '\0'; + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + } } #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { @@ -4602,7 +4602,7 @@ PP(pp_lc) } #endif if (dest != source && SvTAINTED(source)) - SvTAINT(dest); + SvTAINT(dest); SvSETMAGIC(dest); return NORMAL; } @@ -4616,71 +4616,71 @@ PP(pp_quotemeta) SvUTF8_off(TARG); /* decontaminate */ if (len) { - char *d; - SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - d = SvPVX(TARG); - if (DO_UTF8(sv)) { - while (len) { - STRLEN ulen = UTF8SKIP(s); - bool to_quote = FALSE; - - if (UTF8_IS_INVARIANT(*s)) { - if (_isQUOTEMETA(*s)) { - to_quote = TRUE; - } - } - else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) { - if ( + char *d; + SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + d = SvPVX(TARG); + if (DO_UTF8(sv)) { + while (len) { + STRLEN ulen = UTF8SKIP(s); + bool to_quote = FALSE; + + if (UTF8_IS_INVARIANT(*s)) { + if (_isQUOTEMETA(*s)) { + to_quote = TRUE; + } + } + else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) { + if ( #ifdef USE_LOCALE_CTYPE - /* In locale, we quote all non-ASCII Latin1 chars. - * Otherwise use the quoting rules */ + /* In locale, we quote all non-ASCII Latin1 chars. + * Otherwise use the quoting rules */ - IN_LC_RUNTIME(LC_CTYPE) - || + IN_LC_RUNTIME(LC_CTYPE) + || #endif - _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) - { - to_quote = TRUE; - } - } - else if (is_QUOTEMETA_high(s)) { - to_quote = TRUE; - } - - if (to_quote) { - *d++ = '\\'; - } - if (ulen > len) - ulen = len; - len -= ulen; - while (ulen--) - *d++ = *s++; - } - SvUTF8_on(TARG); - } - else if (IN_UNI_8_BIT) { - while (len--) { - if (_isQUOTEMETA(*s)) - *d++ = '\\'; - *d++ = *s++; - } - } - else { - /* For non UNI_8_BIT (and hence in locale) just quote all \W - * including everything above ASCII */ - while (len--) { - if (!isWORDCHAR_A(*s)) - *d++ = '\\'; - *d++ = *s++; - } - } - *d = '\0'; - SvCUR_set(TARG, d - SvPVX_const(TARG)); - (void)SvPOK_only_UTF8(TARG); + _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) + { + to_quote = TRUE; + } + } + else if (is_QUOTEMETA_high(s)) { + to_quote = TRUE; + } + + if (to_quote) { + *d++ = '\\'; + } + if (ulen > len) + ulen = len; + len -= ulen; + while (ulen--) + *d++ = *s++; + } + SvUTF8_on(TARG); + } + else if (IN_UNI_8_BIT) { + while (len--) { + if (_isQUOTEMETA(*s)) + *d++ = '\\'; + *d++ = *s++; + } + } + else { + /* For non UNI_8_BIT (and hence in locale) just quote all \W + * including everything above ASCII */ + while (len--) { + if (!isWORDCHAR_A(*s)) + *d++ = '\\'; + *d++ = *s++; + } + } + *d = '\0'; + SvCUR_set(TARG, d - SvPVX_const(TARG)); + (void)SvPOK_only_UTF8(TARG); } else - sv_setpvn(TARG, s, len); + sv_setpvn(TARG, s, len); SETTARG; return NORMAL; } @@ -4723,9 +4723,9 @@ PP(pp_fc) s = (const U8*)SvPV_nomg_const(source, len); } else { if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(source); - s = (const U8*)""; - len = 0; + report_uninit(source); + s = (const U8*)""; + len = 0; } min = len + 1; @@ -4888,7 +4888,7 @@ PP(pp_fc) } #endif if (SvTAINTED(source)) - SvTAINT(dest); + SvTAINT(dest); SvSETMAGIC(dest); RETURN; } @@ -4902,59 +4902,59 @@ PP(pp_aslice) const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); if (SvTYPE(av) == SVt_PVAV) { - const bool localizing = PL_op->op_private & OPpLVAL_INTRO; - bool can_preserve = FALSE; - - if (localizing) { - MAGIC *mg; - HV *stash; - - can_preserve = SvCANEXISTDELETE(av); - } - - if (lval && localizing) { - SV **svp; - SSize_t max = -1; - for (svp = MARK + 1; svp <= SP; svp++) { - const SSize_t elem = SvIV(*svp); - if (elem > max) - max = elem; - } - if (max > AvMAX(av)) - av_extend(av, max); - } - - while (++MARK <= SP) { - SV **svp; - SSize_t elem = SvIV(*MARK); - bool preeminent = TRUE; - - if (localizing && can_preserve) { - /* If we can determine whether the element exist, - * Try to preserve the existenceness of a tied array - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise. */ - preeminent = av_exists(av, elem); - } - - svp = av_fetch(av, elem, lval); - if (lval) { - if (!svp || !*svp) - DIE(aTHX_ PL_no_aelem, elem); - if (localizing) { - if (preeminent) - save_aelem(av, elem, svp); - else - SAVEADELETE(av, elem); - } - } - *MARK = svp ? *svp : &PL_sv_undef; - } + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool can_preserve = FALSE; + + if (localizing) { + MAGIC *mg; + HV *stash; + + can_preserve = SvCANEXISTDELETE(av); + } + + if (lval && localizing) { + SV **svp; + SSize_t max = -1; + for (svp = MARK + 1; svp <= SP; svp++) { + const SSize_t elem = SvIV(*svp); + if (elem > max) + max = elem; + } + if (max > AvMAX(av)) + av_extend(av, max); + } + + while (++MARK <= SP) { + SV **svp; + SSize_t elem = SvIV(*MARK); + bool preeminent = TRUE; + + if (localizing && can_preserve) { + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + preeminent = av_exists(av, elem); + } + + svp = av_fetch(av, elem, lval); + if (lval) { + if (!svp || !*svp) + DIE(aTHX_ PL_no_aelem, elem); + if (localizing) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } + } + *MARK = svp ? *svp : &PL_sv_undef; + } } if (GIMME_V != G_ARRAY) { - MARK = ORIGMARK; - *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; - SP = MARK; + MARK = ORIGMARK; + *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; + SP = MARK; } RETURN; } @@ -4971,15 +4971,15 @@ PP(pp_kvaslice) if (flags) { if (!(flags & OPpENTERSUB_INARGS)) /* diag_listed_as: Can't modify %s in %s */ - Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); - lval = flags; + Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); + lval = flags; } } MEXTEND(SP,items); while (items > 1) { - *(MARK+items*2-1) = *(MARK+items); - items--; + *(MARK+items*2-1) = *(MARK+items); + items--; } items = SP-MARK; SP += items; @@ -4987,19 +4987,19 @@ PP(pp_kvaslice) while (++MARK <= SP) { SV **svp; - svp = av_fetch(av, SvIV(*MARK), lval); + svp = av_fetch(av, SvIV(*MARK), lval); if (lval) { if (!svp || !*svp || *svp == &PL_sv_undef) { DIE(aTHX_ PL_no_aelem, SvIV(*MARK)); } - *MARK = sv_mortalcopy(*MARK); + *MARK = sv_mortalcopy(*MARK); } - *++MARK = svp ? *svp : &PL_sv_undef; + *++MARK = svp ? *svp : &PL_sv_undef; } if (GIMME_V != G_ARRAY) { - MARK = SP - items*2; - *++MARK = items > 0 ? *SP : &PL_sv_undef; - SP = MARK; + MARK = SP - items*2; + *++MARK = items > 0 ? *SP : &PL_sv_undef; + SP = MARK; } RETURN; } @@ -5014,17 +5014,17 @@ PP(pp_aeach) const IV current = (*iterp)++; if (current > av_top_index(array)) { - *iterp = 0; - if (gimme == G_SCALAR) - RETPUSHUNDEF; - else - RETURN; + *iterp = 0; + if (gimme == G_SCALAR) + RETPUSHUNDEF; + else + RETURN; } EXTEND(SP, 2); mPUSHi(current); if (gimme == G_ARRAY) { - SV **const element = av_fetch(array, current, 0); + SV **const element = av_fetch(array, current, 0); PUSHs(element ? *element : &PL_sv_undef); } RETURN; @@ -5040,8 +5040,8 @@ PP(pp_akeys) *Perl_av_iter_p(aTHX_ array) = 0; if (gimme == G_SCALAR) { - dTARGET; - PUSHi(av_count(array)); + dTARGET; + PUSHi(av_count(array)); } else if (gimme == G_ARRAY) { if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { @@ -5057,20 +5057,20 @@ PP(pp_akeys) EXTEND(SP, n + 1); - if ( PL_op->op_type == OP_AKEYS - || ( PL_op->op_type == OP_AVHVSWITCH - && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) - { - for (i = 0; i <= n; i++) { - mPUSHi(i); - } - } - else { - for (i = 0; i <= n; i++) { - SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); - PUSHs(elem ? *elem : &PL_sv_undef); - } - } + if ( PL_op->op_type == OP_AKEYS + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) + { + for (i = 0; i <= n; i++) { + mPUSHi(i); + } + } + else { + for (i = 0; i <= n; i++) { + SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); + PUSHs(elem ? *elem : &PL_sv_undef); + } + } } } RETURN; @@ -5089,16 +5089,16 @@ PP(pp_each) EXTEND(SP, 2); if (entry) { - SV* const sv = hv_iterkeysv(entry); - PUSHs(sv); - if (gimme == G_ARRAY) { - SV *val; - val = hv_iterval(hash, entry); - PUSHs(val); - } + SV* const sv = hv_iterkeysv(entry); + PUSHs(sv); + if (gimme == G_ARRAY) { + SV *val; + val = hv_iterval(hash, entry); + PUSHs(val); + } } else if (gimme == G_SCALAR) - RETPUSHUNDEF; + RETPUSHUNDEF; RETURN; } @@ -5116,100 +5116,100 @@ S_do_delete_local(pTHX) SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1; dORIGMARK; const bool tied = SvRMAGICAL(osv) - && mg_find((const SV *)osv, PERL_MAGIC_tied); + && mg_find((const SV *)osv, PERL_MAGIC_tied); const bool can_preserve = SvCANEXISTDELETE(osv); const U32 type = SvTYPE(osv); SV ** const end = sliced ? SP : unsliced_keysv; if (type == SVt_PVHV) { /* hash element */ - HV * const hv = MUTABLE_HV(osv); - while (++MARK <= end) { - SV * const keysv = *MARK; - SV *sv = NULL; - bool preeminent = TRUE; - if (can_preserve) - preeminent = hv_exists_ent(hv, keysv, 0); - if (tied) { - HE *he = hv_fetch_ent(hv, keysv, 1, 0); - if (he) - sv = HeVAL(he); - else - preeminent = FALSE; - } - else { - sv = hv_delete_ent(hv, keysv, 0, 0); - if (preeminent) - SvREFCNT_inc_simple_void(sv); /* De-mortalize */ - } - if (preeminent) { - if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); - save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); - if (tied) { - *MARK = sv_mortalcopy(sv); - mg_clear(sv); - } else - *MARK = sv; - } - else { - SAVEHDELETE(hv, keysv); - *MARK = &PL_sv_undef; - } - } + HV * const hv = MUTABLE_HV(osv); + while (++MARK <= end) { + SV * const keysv = *MARK; + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = hv_exists_ent(hv, keysv, 0); + if (tied) { + HE *he = hv_fetch_ent(hv, keysv, 1, 0); + if (he) + sv = HeVAL(he); + else + preeminent = FALSE; + } + else { + sv = hv_delete_ent(hv, keysv, 0, 0); + if (preeminent) + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEHDELETE(hv, keysv); + *MARK = &PL_sv_undef; + } + } } else if (type == SVt_PVAV) { /* array element */ - if (PL_op->op_flags & OPf_SPECIAL) { - AV * const av = MUTABLE_AV(osv); - while (++MARK <= end) { - SSize_t idx = SvIV(*MARK); - SV *sv = NULL; - bool preeminent = TRUE; - if (can_preserve) - preeminent = av_exists(av, idx); - if (tied) { - SV **svp = av_fetch(av, idx, 1); - if (svp) - sv = *svp; - else - preeminent = FALSE; - } - else { - sv = av_delete(av, idx, 0); - if (preeminent) - SvREFCNT_inc_simple_void(sv); /* De-mortalize */ - } - if (preeminent) { - save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); - if (tied) { - *MARK = sv_mortalcopy(sv); - mg_clear(sv); - } else - *MARK = sv; - } - else { - SAVEADELETE(av, idx); - *MARK = &PL_sv_undef; - } - } - } - else - DIE(aTHX_ "panic: avhv_delete no longer supported"); + if (PL_op->op_flags & OPf_SPECIAL) { + AV * const av = MUTABLE_AV(osv); + while (++MARK <= end) { + SSize_t idx = SvIV(*MARK); + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = av_exists(av, idx); + if (tied) { + SV **svp = av_fetch(av, idx, 1); + if (svp) + sv = *svp; + else + preeminent = FALSE; + } + else { + sv = av_delete(av, idx, 0); + if (preeminent) + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEADELETE(av, idx); + *MARK = &PL_sv_undef; + } + } + } + else + DIE(aTHX_ "panic: avhv_delete no longer supported"); } else - DIE(aTHX_ "Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); if (sliced) { - if (gimme == G_VOID) - SP = ORIGMARK; - else if (gimme == G_SCALAR) { - MARK = ORIGMARK; - if (SP > MARK) - *++MARK = *SP; - else - *++MARK = &PL_sv_undef; - SP = MARK; - } + if (gimme == G_VOID) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { + MARK = ORIGMARK; + if (SP > MARK) + *++MARK = *SP; + else + *++MARK = &PL_sv_undef; + SP = MARK; + } } else if (gimme != G_VOID) - PUSHs(*unsliced_keysv); + PUSHs(*unsliced_keysv); RETURN; } @@ -5221,15 +5221,15 @@ PP(pp_delete) I32 discard; if (PL_op->op_private & OPpLVAL_INTRO) - return do_delete_local(); + return do_delete_local(); gimme = GIMME_V; discard = (gimme == G_VOID) ? G_DISCARD : 0; if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) { - dMARK; dORIGMARK; - HV * const hv = MUTABLE_HV(POPs); - const U32 hvtype = SvTYPE(hv); + dMARK; dORIGMARK; + HV * const hv = MUTABLE_HV(POPs); + const U32 hvtype = SvTYPE(hv); int skip = 0; if (PL_op->op_private & OPpKVSLICE) { SSize_t items = SP - MARK; @@ -5243,51 +5243,51 @@ PP(pp_delete) SP += items; skip = 1; } - if (hvtype == SVt_PVHV) { /* hash element */ + if (hvtype == SVt_PVHV) { /* hash element */ while ((MARK += (1+skip)) <= SP) { SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0); - *MARK = sv ? sv : &PL_sv_undef; - } - } - else if (hvtype == SVt_PVAV) { /* array element */ + *MARK = sv ? sv : &PL_sv_undef; + } + } + else if (hvtype == SVt_PVAV) { /* array element */ if (PL_op->op_flags & OPf_SPECIAL) { while ((MARK += (1+skip)) <= SP) { SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard); *MARK = sv ? sv : &PL_sv_undef; } } - } - else - DIE(aTHX_ "Not a HASH reference"); - if (discard) - SP = ORIGMARK; - else if (gimme == G_SCALAR) { - MARK = ORIGMARK; - if (SP > MARK) - *++MARK = *SP; - else - *++MARK = &PL_sv_undef; - SP = MARK; - } + } + else + DIE(aTHX_ "Not a HASH reference"); + if (discard) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { + MARK = ORIGMARK; + if (SP > MARK) + *++MARK = *SP; + else + *++MARK = &PL_sv_undef; + SP = MARK; + } } else { - SV *keysv = POPs; - HV * const hv = MUTABLE_HV(POPs); - SV *sv = NULL; - if (SvTYPE(hv) == SVt_PVHV) - sv = hv_delete_ent(hv, keysv, discard, 0); - else if (SvTYPE(hv) == SVt_PVAV) { - if (PL_op->op_flags & OPf_SPECIAL) - sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard); - else - DIE(aTHX_ "panic: avhv_delete no longer supported"); - } - else - DIE(aTHX_ "Not a HASH reference"); - if (!sv) - sv = &PL_sv_undef; - if (!discard) - PUSHs(sv); + SV *keysv = POPs; + HV * const hv = MUTABLE_HV(POPs); + SV *sv = NULL; + if (SvTYPE(hv) == SVt_PVHV) + sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) + sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard); + else + DIE(aTHX_ "panic: avhv_delete no longer supported"); + } + else + DIE(aTHX_ "Not a HASH reference"); + if (!sv) + sv = &PL_sv_undef; + if (!discard) + PUSHs(sv); } RETURN; } @@ -5299,29 +5299,29 @@ PP(pp_exists) HV *hv; if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) { - GV *gv; - SV * const sv = POPs; - CV * const cv = sv_2cv(sv, &hv, &gv, 0); - if (cv) - RETPUSHYES; - if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) - RETPUSHYES; - RETPUSHNO; + GV *gv; + SV * const sv = POPs; + CV * const cv = sv_2cv(sv, &hv, &gv, 0); + if (cv) + RETPUSHYES; + if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) + RETPUSHYES; + RETPUSHNO; } tmpsv = POPs; hv = MUTABLE_HV(POPs); if (LIKELY( SvTYPE(hv) == SVt_PVHV )) { - if (hv_exists_ent(hv, tmpsv, 0)) - RETPUSHYES; + if (hv_exists_ent(hv, tmpsv, 0)) + RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { - if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ - if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv))) - RETPUSHYES; - } + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv))) + RETPUSHYES; + } } else { - DIE(aTHX_ "Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); } RETPUSHNO; } @@ -5338,8 +5338,8 @@ PP(pp_hslice) MAGIC *mg; HV *stash; - if (SvCANEXISTDELETE(hv)) - can_preserve = TRUE; + if (SvCANEXISTDELETE(hv)) + can_preserve = TRUE; } while (++MARK <= SP) { @@ -5349,7 +5349,7 @@ PP(pp_hslice) bool preeminent = TRUE; if (localizing && can_preserve) { - /* If we can determine whether the element exist, + /* If we can determine whether the element exist, * try to preserve the existenceness of a tied hash * element by using EXISTS and DELETE if possible. * Fallback to FETCH and STORE otherwise. */ @@ -5364,21 +5364,21 @@ PP(pp_hslice) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } if (localizing) { - if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) - save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else if (preeminent) - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - else - SAVEHDELETE(hv, keysv); + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) + save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); } } *MARK = svp && *svp ? *svp : &PL_sv_undef; } if (GIMME_V != G_ARRAY) { - MARK = ORIGMARK; - *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; - SP = MARK; + MARK = ORIGMARK; + *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; + SP = MARK; } RETURN; } @@ -5395,16 +5395,16 @@ PP(pp_kvhslice) if (flags) { if (!(flags & OPpENTERSUB_INARGS)) /* diag_listed_as: Can't modify %s in %s */ - Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", - GIMME_V == G_ARRAY ? "list" : "scalar"); - lval = flags; + Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", + GIMME_V == G_ARRAY ? "list" : "scalar"); + lval = flags; } } MEXTEND(SP,items); while (items > 1) { - *(MARK+items*2-1) = *(MARK+items); - items--; + *(MARK+items*2-1) = *(MARK+items); + items--; } items = SP-MARK; SP += items; @@ -5421,14 +5421,14 @@ PP(pp_kvhslice) if (!svp || !*svp || *svp == &PL_sv_undef) { DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } - *MARK = sv_mortalcopy(*MARK); + *MARK = sv_mortalcopy(*MARK); } *++MARK = svp && *svp ? *svp : &PL_sv_undef; } if (GIMME_V != G_ARRAY) { - MARK = SP - items*2; - *++MARK = items > 0 ? *SP : &PL_sv_undef; - SP = MARK; + MARK = SP - items*2; + *++MARK = items > 0 ? *SP : &PL_sv_undef; + SP = MARK; } RETURN; } @@ -5441,15 +5441,15 @@ PP(pp_list) if (GIMME_V != G_ARRAY) { /* don't initialize mark here, EXTEND() may move the stack */ SV **mark; - dSP; + dSP; EXTEND(SP, 1); /* in case no arguments, as in @empty */ mark = PL_stack_base + markidx; - if (++MARK <= SP) - *MARK = *SP; /* unwanted list, return last item */ - else - *MARK = &PL_sv_undef; - SP = MARK; - PUTBACK; + if (++MARK <= SP) + *MARK = *SP; /* unwanted list, return last item */ + else + *MARK = &PL_sv_undef; + SP = MARK; + PUTBACK; } return NORMAL; } @@ -5485,23 +5485,23 @@ PP(pp_lslice) } if (max == 0) { - SP = firstlelem - 1; - RETURN; + SP = firstlelem - 1; + RETURN; } for (lelem = firstlelem; lelem <= lastlelem; lelem++) { - I32 ix = SvIV(*lelem); - if (ix < 0) - ix += max; - if (ix < 0 || ix >= max) - *lelem = &PL_sv_undef; - else { - if (!(*lelem = firstrelem[ix])) - *lelem = &PL_sv_undef; - else if (mod && SvPADTMP(*lelem)) { - *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); - } - } + I32 ix = SvIV(*lelem); + if (ix < 0) + ix += max; + if (ix < 0 || ix >= max) + *lelem = &PL_sv_undef; + else { + if (!(*lelem = firstrelem[ix])) + *lelem = &PL_sv_undef; + else if (mod && SvPADTMP(*lelem)) { + *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); + } + } } SP = lastlelem; RETURN; @@ -5514,7 +5514,7 @@ PP(pp_anonlist) SV * const av = MUTABLE_SV(av_make(items, MARK+1)); SP = MARK; mXPUSHs((PL_op->op_flags & OPf_SPECIAL) - ? newRV_noinc(av) : av); + ? newRV_noinc(av) : av); RETURN; } @@ -5527,22 +5527,22 @@ PP(pp_anonhash) : MUTABLE_SV(hv) ); while (MARK < SP) { - SV * const key = - (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK); - SV *val; - if (MARK < SP) - { - MARK++; - SvGETMAGIC(*MARK); - val = newSV(0); - sv_setsv_nomg(val, *MARK); - } - else - { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); - val = newSV(0); - } - (void)hv_store_ent(hv,key,val,0); + SV * const key = + (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK); + SV *val; + if (MARK < SP) + { + MARK++; + SvGETMAGIC(*MARK); + val = newSV(0); + sv_setsv_nomg(val, *MARK); + } + else + { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); + val = newSV(0); + } + (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; XPUSHs(retval); @@ -5565,9 +5565,9 @@ PP(pp_splice) const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { - return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, - GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, - sp - mark); + return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, + GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } if (SvREADONLY(ary)) @@ -5576,37 +5576,37 @@ PP(pp_splice) SP++; if (++MARK < SP) { - offset = i = SvIV(*MARK); - if (offset < 0) - offset += AvFILLp(ary) + 1; - if (offset < 0) - DIE(aTHX_ PL_no_aelem, i); - if (++MARK < SP) { - length = SvIVx(*MARK++); - if (length < 0) { - length += AvFILLp(ary) - offset + 1; - if (length < 0) - length = 0; - } - } - else - length = AvMAX(ary) + 1; /* close enough to infinity */ + offset = i = SvIV(*MARK); + if (offset < 0) + offset += AvFILLp(ary) + 1; + if (offset < 0) + DIE(aTHX_ PL_no_aelem, i); + if (++MARK < SP) { + length = SvIVx(*MARK++); + if (length < 0) { + length += AvFILLp(ary) - offset + 1; + if (length < 0) + length = 0; + } + } + else + length = AvMAX(ary) + 1; /* close enough to infinity */ } else { - offset = 0; - length = AvMAX(ary) + 1; + offset = 0; + length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) { - if (num_args > 2) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); - offset = AvFILLp(ary) + 1; + if (num_args > 2) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); + offset = AvFILLp(ary) + 1; } after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ - length += after; /* offset+length now in array */ - after = 0; - if (!AvALLOC(ary)) - av_extend(ary, 0); + length += after; /* offset+length now in array */ + after = 0; + if (!AvALLOC(ary)) + av_extend(ary, 0); } /* At this point, MARK .. SP-1 is our new LIST */ @@ -5614,153 +5614,153 @@ PP(pp_splice) newlen = SP - MARK; diff = newlen - length; if (newlen && !AvREAL(ary) && AvREIFY(ary)) - av_reify(ary); + av_reify(ary); /* make new elements SVs now: avoid problems if they're from the array */ for (dst = MARK, i = newlen; i; i--) { SV * const h = *dst; - *dst++ = newSVsv(h); + *dst++ = newSVsv(h); } if (diff < 0) { /* shrinking the area */ - SV **tmparyval = NULL; - if (newlen) { - Newx(tmparyval, newlen, SV*); /* so remember insertion */ - Copy(MARK, tmparyval, newlen, SV*); - } - - MARK = ORIGMARK + 1; - if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ - const bool real = cBOOL(AvREAL(ary)); - MEXTEND(MARK, length); - if (real) - EXTEND_MORTAL(length); - for (i = 0, dst = MARK; i < length; i++) { - if ((*dst = AvARRAY(ary)[i+offset])) { - if (real) - sv_2mortal(*dst); /* free them eventually */ - } - else - *dst = &PL_sv_undef; - dst++; - } - MARK += length - 1; - } - else { - *MARK = AvARRAY(ary)[offset+length-1]; - if (AvREAL(ary)) { - sv_2mortal(*MARK); - for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) - SvREFCNT_dec(*dst++); /* free them now */ - } - if (!*MARK) - *MARK = &PL_sv_undef; - } - AvFILLp(ary) += diff; - - /* pull up or down? */ - - if (offset < after) { /* easier to pull up */ - if (offset) { /* esp. if nothing to pull */ - src = &AvARRAY(ary)[offset-1]; - dst = src - diff; /* diff is negative */ - for (i = offset; i > 0; i--) /* can't trust Copy */ - *dst-- = *src--; - } - dst = AvARRAY(ary); - AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ - AvMAX(ary) += diff; - } - else { - if (after) { /* anything to pull down? */ - src = AvARRAY(ary) + offset + length; - dst = src + diff; /* diff is negative */ - Move(src, dst, after, SV*); - } - dst = &AvARRAY(ary)[AvFILLp(ary)+1]; - /* avoid later double free */ - } - i = -diff; - while (i) - dst[--i] = NULL; - - if (newlen) { - Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); - Safefree(tmparyval); - } + SV **tmparyval = NULL; + if (newlen) { + Newx(tmparyval, newlen, SV*); /* so remember insertion */ + Copy(MARK, tmparyval, newlen, SV*); + } + + MARK = ORIGMARK + 1; + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ + const bool real = cBOOL(AvREAL(ary)); + MEXTEND(MARK, length); + if (real) + EXTEND_MORTAL(length); + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = AvARRAY(ary)[i+offset])) { + if (real) + sv_2mortal(*dst); /* free them eventually */ + } + else + *dst = &PL_sv_undef; + dst++; + } + MARK += length - 1; + } + else { + *MARK = AvARRAY(ary)[offset+length-1]; + if (AvREAL(ary)) { + sv_2mortal(*MARK); + for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) + SvREFCNT_dec(*dst++); /* free them now */ + } + if (!*MARK) + *MARK = &PL_sv_undef; + } + AvFILLp(ary) += diff; + + /* pull up or down? */ + + if (offset < after) { /* easier to pull up */ + if (offset) { /* esp. if nothing to pull */ + src = &AvARRAY(ary)[offset-1]; + dst = src - diff; /* diff is negative */ + for (i = offset; i > 0; i--) /* can't trust Copy */ + *dst-- = *src--; + } + dst = AvARRAY(ary); + AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ + AvMAX(ary) += diff; + } + else { + if (after) { /* anything to pull down? */ + src = AvARRAY(ary) + offset + length; + dst = src + diff; /* diff is negative */ + Move(src, dst, after, SV*); + } + dst = &AvARRAY(ary)[AvFILLp(ary)+1]; + /* avoid later double free */ + } + i = -diff; + while (i) + dst[--i] = NULL; + + if (newlen) { + Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); + Safefree(tmparyval); + } } else { /* no, expanding (or same) */ - SV** tmparyval = NULL; - if (length) { - Newx(tmparyval, length, SV*); /* so remember deletion */ - Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); - } - - if (diff > 0) { /* expanding */ - /* push up or down? */ - if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { - if (offset) { - src = AvARRAY(ary); - dst = src - diff; - Move(src, dst, offset, SV*); - } - AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ - AvMAX(ary) += diff; - AvFILLp(ary) += diff; - } - else { - if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ - av_extend(ary, AvFILLp(ary) + diff); - AvFILLp(ary) += diff; - - if (after) { - dst = AvARRAY(ary) + AvFILLp(ary); - src = dst - diff; - for (i = after; i; i--) { - *dst-- = *src--; - } - } - } - } - - if (newlen) { - Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); - } - - MARK = ORIGMARK + 1; - if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ - if (length) { - const bool real = cBOOL(AvREAL(ary)); - if (real) - EXTEND_MORTAL(length); - for (i = 0, dst = MARK; i < length; i++) { - if ((*dst = tmparyval[i])) { - if (real) - sv_2mortal(*dst); /* free them eventually */ - } - else *dst = &PL_sv_undef; - dst++; - } - } - MARK += length - 1; - } - else if (length--) { - *MARK = tmparyval[length]; - if (AvREAL(ary)) { - sv_2mortal(*MARK); - while (length-- > 0) - SvREFCNT_dec(tmparyval[length]); - } - if (!*MARK) - *MARK = &PL_sv_undef; - } - else - *MARK = &PL_sv_undef; - Safefree(tmparyval); + SV** tmparyval = NULL; + if (length) { + Newx(tmparyval, length, SV*); /* so remember deletion */ + Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); + } + + if (diff > 0) { /* expanding */ + /* push up or down? */ + if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { + if (offset) { + src = AvARRAY(ary); + dst = src - diff; + Move(src, dst, offset, SV*); + } + AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ + AvMAX(ary) += diff; + AvFILLp(ary) += diff; + } + else { + if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ + av_extend(ary, AvFILLp(ary) + diff); + AvFILLp(ary) += diff; + + if (after) { + dst = AvARRAY(ary) + AvFILLp(ary); + src = dst - diff; + for (i = after; i; i--) { + *dst-- = *src--; + } + } + } + } + + if (newlen) { + Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); + } + + MARK = ORIGMARK + 1; + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ + if (length) { + const bool real = cBOOL(AvREAL(ary)); + if (real) + EXTEND_MORTAL(length); + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = tmparyval[i])) { + if (real) + sv_2mortal(*dst); /* free them eventually */ + } + else *dst = &PL_sv_undef; + dst++; + } + } + MARK += length - 1; + } + else if (length--) { + *MARK = tmparyval[length]; + if (AvREAL(ary)) { + sv_2mortal(*MARK); + while (length-- > 0) + SvREFCNT_dec(tmparyval[length]); + } + if (!*MARK) + *MARK = &PL_sv_undef; + } + else + *MARK = &PL_sv_undef; + Safefree(tmparyval); } if (SvMAGICAL(ary)) - mg_set(MUTABLE_SV(ary)); + mg_set(MUTABLE_SV(ary)); SP = MARK; RETURN; @@ -5773,36 +5773,36 @@ PP(pp_push) const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { - *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); - PUSHMARK(MARK); - PUTBACK; - ENTER_with_name("call_PUSH"); - call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); - LEAVE_with_name("call_PUSH"); - /* SPAGAIN; not needed: SP is assigned to immediately below */ + *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); + PUSHMARK(MARK); + PUTBACK; + ENTER_with_name("call_PUSH"); + call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); + LEAVE_with_name("call_PUSH"); + /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we * only need to save locally, not on the save stack */ U16 old_delaymagic = PL_delaymagic; - if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); - PL_delaymagic = DM_DELAY; - for (++MARK; MARK <= SP; MARK++) { - SV *sv; - if (*MARK) SvGETMAGIC(*MARK); - sv = newSV(0); - if (*MARK) - sv_setsv_nomg(sv, *MARK); - av_store(ary, AvFILLp(ary)+1, sv); - } - if (PL_delaymagic & DM_ARRAY_ISA) - mg_set(MUTABLE_SV(ary)); + if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); + PL_delaymagic = DM_DELAY; + for (++MARK; MARK <= SP; MARK++) { + SV *sv; + if (*MARK) SvGETMAGIC(*MARK); + sv = newSV(0); + if (*MARK) + sv_setsv_nomg(sv, *MARK); + av_store(ary, AvFILLp(ary)+1, sv); + } + if (PL_delaymagic & DM_ARRAY_ISA) + mg_set(MUTABLE_SV(ary)); PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { - PUSHi( AvFILL(ary) + 1 ); + PUSHi( AvFILL(ary) + 1 ); } RETURN; } @@ -5812,12 +5812,12 @@ PP(pp_shift) { dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL - ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); + ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); EXTEND(SP, 1); assert (sv); if (AvREAL(av)) - (void)sv_2mortal(sv); + (void)sv_2mortal(sv); PUSHs(sv); RETURN; } @@ -5829,33 +5829,33 @@ PP(pp_unshift) const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { - *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); - PUSHMARK(MARK); - PUTBACK; - ENTER_with_name("call_UNSHIFT"); - call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); - LEAVE_with_name("call_UNSHIFT"); - /* SPAGAIN; not needed: SP is assigned to immediately below */ + *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); + PUSHMARK(MARK); + PUTBACK; + ENTER_with_name("call_UNSHIFT"); + call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); + LEAVE_with_name("call_UNSHIFT"); + /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we * only need to save locally, not on the save stack */ U16 old_delaymagic = PL_delaymagic; - SSize_t i = 0; + SSize_t i = 0; - av_unshift(ary, SP - MARK); + av_unshift(ary, SP - MARK); PL_delaymagic = DM_DELAY; - while (MARK < SP) { - SV * const sv = newSVsv(*++MARK); - (void)av_store(ary, i++, sv); - } + while (MARK < SP) { + SV * const sv = newSVsv(*++MARK); + (void)av_store(ary, i++, sv); + } if (PL_delaymagic & DM_ARRAY_ISA) mg_set(MUTABLE_SV(ary)); PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { - PUSHi( AvFILL(ary) + 1 ); + PUSHi( AvFILL(ary) + 1 ); } RETURN; } @@ -5865,132 +5865,132 @@ PP(pp_reverse) dSP; dMARK; if (GIMME_V == G_ARRAY) { - if (PL_op->op_private & OPpREVERSE_INPLACE) { - AV *av; - - /* See pp_sort() */ - assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); - (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ - av = MUTABLE_AV((*SP)); - /* In-place reversing only happens in void context for the array - * assignment. We don't need to push anything on the stack. */ - SP = MARK; - - if (SvMAGICAL(av)) { - SSize_t i, j; - SV *tmp = sv_newmortal(); - /* For SvCANEXISTDELETE */ - HV *stash; - const MAGIC *mg; - bool can_preserve = SvCANEXISTDELETE(av); - - for (i = 0, j = av_top_index(av); i < j; ++i, --j) { - SV *begin, *end; - - if (can_preserve) { - if (!av_exists(av, i)) { - if (av_exists(av, j)) { - SV *sv = av_delete(av, j, 0); - begin = *av_fetch(av, i, TRUE); - sv_setsv_mg(begin, sv); - } - continue; - } - else if (!av_exists(av, j)) { - SV *sv = av_delete(av, i, 0); - end = *av_fetch(av, j, TRUE); - sv_setsv_mg(end, sv); - continue; - } - } - - begin = *av_fetch(av, i, TRUE); - end = *av_fetch(av, j, TRUE); - sv_setsv(tmp, begin); - sv_setsv_mg(begin, end); - sv_setsv_mg(end, tmp); - } - } - else { - SV **begin = AvARRAY(av); - - if (begin) { - SV **end = begin + AvFILLp(av); - - while (begin < end) { - SV * const tmp = *begin; - *begin++ = *end; - *end-- = tmp; - } - } - } - } - else { - SV **oldsp = SP; - MARK++; - while (MARK < SP) { - SV * const tmp = *MARK; - *MARK++ = *SP; - *SP-- = tmp; - } - /* safe as long as stack cannot get extended in the above */ - SP = oldsp; - } + if (PL_op->op_private & OPpREVERSE_INPLACE) { + AV *av; + + /* See pp_sort() */ + assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); + (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ + av = MUTABLE_AV((*SP)); + /* In-place reversing only happens in void context for the array + * assignment. We don't need to push anything on the stack. */ + SP = MARK; + + if (SvMAGICAL(av)) { + SSize_t i, j; + SV *tmp = sv_newmortal(); + /* For SvCANEXISTDELETE */ + HV *stash; + const MAGIC *mg; + bool can_preserve = SvCANEXISTDELETE(av); + + for (i = 0, j = av_top_index(av); i < j; ++i, --j) { + SV *begin, *end; + + if (can_preserve) { + if (!av_exists(av, i)) { + if (av_exists(av, j)) { + SV *sv = av_delete(av, j, 0); + begin = *av_fetch(av, i, TRUE); + sv_setsv_mg(begin, sv); + } + continue; + } + else if (!av_exists(av, j)) { + SV *sv = av_delete(av, i, 0); + end = *av_fetch(av, j, TRUE); + sv_setsv_mg(end, sv); + continue; + } + } + + begin = *av_fetch(av, i, TRUE); + end = *av_fetch(av, j, TRUE); + sv_setsv(tmp, begin); + sv_setsv_mg(begin, end); + sv_setsv_mg(end, tmp); + } + } + else { + SV **begin = AvARRAY(av); + + if (begin) { + SV **end = begin + AvFILLp(av); + + while (begin < end) { + SV * const tmp = *begin; + *begin++ = *end; + *end-- = tmp; + } + } + } + } + else { + SV **oldsp = SP; + MARK++; + while (MARK < SP) { + SV * const tmp = *MARK; + *MARK++ = *SP; + *SP-- = tmp; + } + /* safe as long as stack cannot get extended in the above */ + SP = oldsp; + } } else { - char *up; - dTARGET; - STRLEN len; - - SvUTF8_off(TARG); /* decontaminate */ - if (SP - MARK > 1) { - do_join(TARG, &PL_sv_no, MARK, SP); - SP = MARK + 1; - SETs(TARG); - } else if (SP > MARK) { - sv_setsv(TARG, *SP); - SETs(TARG); + char *up; + dTARGET; + STRLEN len; + + SvUTF8_off(TARG); /* decontaminate */ + if (SP - MARK > 1) { + do_join(TARG, &PL_sv_no, MARK, SP); + SP = MARK + 1; + SETs(TARG); + } else if (SP > MARK) { + sv_setsv(TARG, *SP); + SETs(TARG); } else { - sv_setsv(TARG, DEFSV); - XPUSHs(TARG); - } + sv_setsv(TARG, DEFSV); + XPUSHs(TARG); + } SvSETMAGIC(TARG); /* remove any utf8 length magic */ - up = SvPV_force(TARG, len); - if (len > 1) { + up = SvPV_force(TARG, len); + if (len > 1) { char *down; - if (DO_UTF8(TARG)) { /* first reverse each character */ - U8* s = (U8*)SvPVX(TARG); - const U8* send = (U8*)(s + len); - while (s < send) { - if (UTF8_IS_INVARIANT(*s)) { - s++; - continue; - } - else { - if (!utf8_to_uvchr_buf(s, send, 0)) - break; - up = (char*)s; - s += UTF8SKIP(s); - down = (char*)(s - 1); - /* reverse this character */ - while (down > up) { + if (DO_UTF8(TARG)) { /* first reverse each character */ + U8* s = (U8*)SvPVX(TARG); + const U8* send = (U8*)(s + len); + while (s < send) { + if (UTF8_IS_INVARIANT(*s)) { + s++; + continue; + } + else { + if (!utf8_to_uvchr_buf(s, send, 0)) + break; + up = (char*)s; + s += UTF8SKIP(s); + down = (char*)(s - 1); + /* reverse this character */ + while (down > up) { const char tmp = *up; - *up++ = *down; + *up++ = *down; *down-- = tmp; - } - } - } - up = SvPVX(TARG); - } - down = SvPVX(TARG) + len - 1; - while (down > up) { + } + } + } + up = SvPVX(TARG); + } + down = SvPVX(TARG) + len - 1; + while (down > up) { const char tmp = *up; - *up++ = *down; + *up++ = *down; *down-- = tmp; - } - (void)SvPOK_only_UTF8(TARG); - } + } + (void)SvPOK_only_UTF8(TARG); + } } RETURN; } @@ -6036,7 +6036,7 @@ PP(pp_split) /* handle @ary = split(...) optimisation */ if (PL_op->op_private & OPpSPLIT_ASSIGN) { - realarray = 1; + realarray = 1; if (!(PL_op->op_flags & OPf_STACKED)) { if (PL_op->op_private & OPpSPLIT_LEX) { if (PL_op->op_private & OPpLVAL_INTRO) @@ -6059,60 +6059,60 @@ PP(pp_split) oldsave = PL_savestack_ix; } - /* Some defence against stack-not-refcounted bugs */ - (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary)); + /* Some defence against stack-not-refcounted bugs */ + (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary)); - if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); - } else { - flags &= ~SVs_TEMP; /* SVs will not be mortal */ - } + if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); + } else { + flags &= ~SVs_TEMP; /* SVs will not be mortal */ + } } base = SP - PL_stack_base; orig = s; if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) { - if (do_utf8) { - while (s < strend && isSPACE_utf8_safe(s, strend)) - s += UTF8SKIP(s); - } - else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { - while (s < strend && isSPACE_LC(*s)) - s++; - } + if (do_utf8) { + while (s < strend && isSPACE_utf8_safe(s, strend)) + s += UTF8SKIP(s); + } + else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { + while (s < strend && isSPACE_LC(*s)) + s++; + } else if (in_uni_8_bit) { while (s < strend && isSPACE_L1(*s)) s++; } - else { - while (s < strend && isSPACE(*s)) - s++; - } + else { + while (s < strend && isSPACE(*s)) + s++; + } } gimme_scalar = gimme == G_SCALAR && !ary; if (!limit) - limit = maxiters + 2; + limit = maxiters + 2; if (RX_EXTFLAGS(rx) & RXf_WHITE) { - while (--limit) { - m = s; - /* this one uses 'm' and is a negative test */ - if (do_utf8) { - while (m < strend && ! isSPACE_utf8_safe(m, strend) ) { - const int t = UTF8SKIP(m); - /* isSPACE_utf8_safe returns FALSE for malform utf8 */ - if (strend - m < t) - m = strend; - else - m += t; - } - } - else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) + while (--limit) { + m = s; + /* this one uses 'm' and is a negative test */ + if (do_utf8) { + while (m < strend && ! isSPACE_utf8_safe(m, strend) ) { + const int t = UTF8SKIP(m); + /* isSPACE_utf8_safe returns FALSE for malform utf8 */ + if (strend - m < t) + m = strend; + else + m += t; + } + } + else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { - while (m < strend && !isSPACE_LC(*m)) - ++m; + while (m < strend && !isSPACE_LC(*m)) + ++m; } else if (in_uni_8_bit) { while (m < strend && !isSPACE_L1(*m)) @@ -6121,35 +6121,35 @@ PP(pp_split) while (m < strend && !isSPACE(*m)) ++m; } - if (m >= strend) - break; - - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - dstr = newSVpvn_flags(s, m-s, flags); - XPUSHs(dstr); - } - - /* skip the whitespace found last */ - if (do_utf8) - s = m + UTF8SKIP(m); - else - s = m + 1; - - /* this one uses 's' and is a positive test */ - if (do_utf8) { - while (s < strend && isSPACE_utf8_safe(s, strend) ) - s += UTF8SKIP(s); - } - else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) + if (m >= strend) + break; + + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, flags); + XPUSHs(dstr); + } + + /* skip the whitespace found last */ + if (do_utf8) + s = m + UTF8SKIP(m); + else + s = m + 1; + + /* this one uses 's' and is a positive test */ + if (do_utf8) { + while (s < strend && isSPACE_utf8_safe(s, strend) ) + s += UTF8SKIP(s); + } + else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { - while (s < strend && isSPACE_LC(*s)) - ++s; + while (s < strend && isSPACE_LC(*s)) + ++s; } else if (in_uni_8_bit) { while (s < strend && isSPACE_L1(*s)) @@ -6158,28 +6158,28 @@ PP(pp_split) while (s < strend && isSPACE(*s)) ++s; } - } + } } else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) { - while (--limit) { - for (m = s; m < strend && *m != '\n'; m++) - ; - m++; - if (m >= strend) - break; - - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - dstr = newSVpvn_flags(s, m-s, flags); - XPUSHs(dstr); - } - s = m; - } + while (--limit) { + for (m = s; m < strend && *m != '\n'; m++) + ; + m++; + if (m >= strend) + break; + + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, flags); + XPUSHs(dstr); + } + s = m; + } } else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) { /* This case boils down to deciding which is the smaller of: @@ -6232,147 +6232,147 @@ PP(pp_split) } } else if (do_utf8 == (RX_UTF8(rx) != 0) && - (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) - && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) + (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) + && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) { - const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); - SV * const csv = CALLREG_INTUIT_STRING(rx); - - len = RX_MINLENRET(rx); - if (len == 1 && !RX_UTF8(rx) && !tail) { - const char c = *SvPV_nolen_const(csv); - while (--limit) { - for (m = s; m < strend && *m != c; m++) - ; - if (m >= strend) - break; - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - dstr = newSVpvn_flags(s, m-s, flags); - XPUSHs(dstr); - } - /* The rx->minlen is in characters but we want to step - * s ahead by bytes. */ - if (do_utf8) - s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend); - else - s = m + len; /* Fake \n at the end */ - } - } - else { - const bool multiline = (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) ? 1 : 0; - - while (s < strend && --limit && - (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, - csv, multiline ? FBMrf_MULTILINE : 0)) ) - { - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - dstr = newSVpvn_flags(s, m-s, flags); - XPUSHs(dstr); - } - /* The rx->minlen is in characters but we want to step - * s ahead by bytes. */ - if (do_utf8) - s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend); - else - s = m + len; /* Fake \n at the end */ - } - } + const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); + SV * const csv = CALLREG_INTUIT_STRING(rx); + + len = RX_MINLENRET(rx); + if (len == 1 && !RX_UTF8(rx) && !tail) { + const char c = *SvPV_nolen_const(csv); + while (--limit) { + for (m = s; m < strend && *m != c; m++) + ; + if (m >= strend) + break; + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, flags); + XPUSHs(dstr); + } + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend); + else + s = m + len; /* Fake \n at the end */ + } + } + else { + const bool multiline = (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) ? 1 : 0; + + while (s < strend && --limit && + (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, + csv, multiline ? FBMrf_MULTILINE : 0)) ) + { + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, flags); + XPUSHs(dstr); + } + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend); + else + s = m + len; /* Fake \n at the end */ + } + } } else { - maxiters += slen * RX_NPARENS(rx); - while (s < strend && --limit) - { - I32 rex_return; - PUTBACK; - rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1, - sv, NULL, 0); - SPAGAIN; - if (rex_return == 0) - break; - TAINT_IF(RX_MATCH_TAINTED(rx)); + maxiters += slen * RX_NPARENS(rx); + while (s < strend && --limit) + { + I32 rex_return; + PUTBACK; + rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1, + sv, NULL, 0); + SPAGAIN; + if (rex_return == 0) + break; + TAINT_IF(RX_MATCH_TAINTED(rx)); /* we never pass the REXEC_COPY_STR flag, so it should * never get copied */ assert(!RX_MATCH_COPIED(rx)); - m = RX_OFFS(rx)[0].start + orig; - - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - dstr = newSVpvn_flags(s, m-s, flags); - XPUSHs(dstr); - } - if (RX_NPARENS(rx)) { - I32 i; - for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { - s = RX_OFFS(rx)[i].start + orig; - m = RX_OFFS(rx)[i].end + orig; - - /* japhy (07/27/01) -- the (m && s) test doesn't catch - parens that didn't match -- they should be set to - undef, not the empty string */ - if (gimme_scalar) { - iters++; - if (m-s == 0) - trailing_empty++; - else - trailing_empty = 0; - } else { - if (m >= orig && s >= orig) { - dstr = newSVpvn_flags(s, m-s, flags); - } - else - dstr = &PL_sv_undef; /* undef, not "" */ - XPUSHs(dstr); - } - - } - } - s = RX_OFFS(rx)[0].end + orig; - } + m = RX_OFFS(rx)[0].start + orig; + + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, flags); + XPUSHs(dstr); + } + if (RX_NPARENS(rx)) { + I32 i; + for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { + s = RX_OFFS(rx)[i].start + orig; + m = RX_OFFS(rx)[i].end + orig; + + /* japhy (07/27/01) -- the (m && s) test doesn't catch + parens that didn't match -- they should be set to + undef, not the empty string */ + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + if (m >= orig && s >= orig) { + dstr = newSVpvn_flags(s, m-s, flags); + } + else + dstr = &PL_sv_undef; /* undef, not "" */ + XPUSHs(dstr); + } + + } + } + s = RX_OFFS(rx)[0].end + orig; + } } if (!gimme_scalar) { - iters = (SP - PL_stack_base) - base; + iters = (SP - PL_stack_base) - base; } if (iters > maxiters) - DIE(aTHX_ "Split loop"); + DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - if (!gimme_scalar) { - const STRLEN l = strend - s; - dstr = newSVpvn_flags(s, l, flags); - XPUSHs(dstr); - } - iters++; + if (!gimme_scalar) { + const STRLEN l = strend - s; + dstr = newSVpvn_flags(s, l, flags); + XPUSHs(dstr); + } + iters++; } else if (!origlimit) { - if (gimme_scalar) { - iters -= trailing_empty; - } else { - while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { - if (TOPs && !(flags & SVs_TEMP)) - sv_2mortal(TOPs); - *SP-- = NULL; - iters--; - } - } + if (gimme_scalar) { + iters -= trailing_empty; + } else { + while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { + if (TOPs && !(flags & SVs_TEMP)) + sv_2mortal(TOPs); + *SP-- = NULL; + iters--; + } + } } PUTBACK; @@ -6403,8 +6403,8 @@ PP(pp_split) if (SvSMAGICAL(ary)) { PUTBACK; - mg_set(MUTABLE_SV(ary)); - SPAGAIN; + mg_set(MUTABLE_SV(ary)); + SPAGAIN; } if (gimme != G_ARRAY) { @@ -6414,8 +6414,8 @@ PP(pp_split) SP -= iters; PUTBACK; } - } - else { + } + else { PUTBACK; av_extend(ary,iters); av_clear(ary); @@ -6425,17 +6425,17 @@ PP(pp_split) LEAVE_with_name("call_PUSH"); SPAGAIN; - if (gimme == G_ARRAY) { - SSize_t i; - /* EXTEND should not be needed - we just popped them */ - EXTEND_SKIP(SP, iters); - for (i=0; i < iters; i++) { - SV **svp = av_fetch(ary, i, FALSE); - PUSHs((svp) ? *svp : &PL_sv_undef); - } - RETURN; - } - } + if (gimme == G_ARRAY) { + SSize_t i; + /* EXTEND should not be needed - we just popped them */ + EXTEND_SKIP(SP, iters); + for (i=0; i < iters; i++) { + SV **svp = av_fetch(ary, i, FALSE); + PUSHs((svp) ? *svp : &PL_sv_undef); + } + RETURN; + } + } } if (gimme != G_ARRAY) { @@ -6452,9 +6452,9 @@ PP(pp_once) SV *const sv = PAD_SVl(PL_op->op_targ); if (SvPADSTALE(sv)) { - /* First time. */ - SvPADSTALE_off(sv); - RETURNOP(cLOGOP->op_other); + /* First time. */ + SvPADSTALE_off(sv); + RETURNOP(cLOGOP->op_other); } RETURNOP(cLOGOP->op_next); } @@ -6467,7 +6467,7 @@ PP(pp_lock) SvLOCK(sv); if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { - retsv = refto(retsv); + retsv = refto(retsv); } SETs(retsv); RETURN; @@ -6489,9 +6489,9 @@ PP(unimplemented_op) registers &Perl_unimplemented_op as the address of their custom op. NULL doesn't generate a useful error message. "custom" does. */ const char *const name = op_type >= OP_max - ? "[out of range]" : PL_op_name[op_type]; + ? "[out of range]" : PL_op_name[op_type]; if(OP_IS_SOCKET(op_type)) - DIE(aTHX_ PL_no_sock_func, name); + DIE(aTHX_ PL_no_sock_func, name); DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); } @@ -6499,11 +6499,11 @@ static void S_maybe_unwind_defav(pTHX) { if (CX_CUR()->cx_type & CXp_HASARGS) { - PERL_CONTEXT *cx = CX_CUR(); + PERL_CONTEXT *cx = CX_CUR(); assert(CxHASARGS(cx)); cx_popsub_args(cx); - cx->cx_type &= ~CXp_HASARGS; + cx->cx_type &= ~CXp_HASARGS; } } @@ -6524,21 +6524,21 @@ PP(pp_coreargs) /* Count how many args there are first, to get some idea how far to extend the stack. */ while (oa) { - if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; } - maxargs++; - if (oa & OA_OPTIONAL) seen_question = 1; - if (!seen_question) minargs++; - oa >>= 4; + if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; } + maxargs++; + if (oa & OA_OPTIONAL) seen_question = 1; + if (!seen_question) minargs++; + oa >>= 4; } if(numargs < minargs) err = "Not enough"; else if(numargs > maxargs) err = "Too many"; if (err) - /* diag_listed_as: Too many arguments for %s */ - Perl_croak(aTHX_ - "%s arguments for %s", err, - opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv) - ); + /* diag_listed_as: Too many arguments for %s */ + Perl_croak(aTHX_ + "%s arguments for %s", err, + opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv) + ); /* Reset the stack pointer. Without this, we end up returning our own arguments in list context, in addition to the values we are supposed @@ -6553,8 +6553,8 @@ PP(pp_coreargs) to come in between two things this function does (stack reset and arg pushing). This seems the easiest way to do it. */ if (pushmark) { - PUTBACK; - (void)Perl_pp_pushmark(aTHX); + PUTBACK; + (void)Perl_pp_pushmark(aTHX); } EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs); @@ -6562,109 +6562,109 @@ PP(pp_coreargs) oa = PL_opargs[opnum] >> OASHIFT; for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) { - whicharg++; - switch (oa & 7) { - case OA_SCALAR: - try_defsv: - if (!numargs && defgv && whicharg == minargs + 1) { - PUSHs(DEFSV); - } - else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); - break; - case OA_LIST: - while (numargs--) { - PUSHs(svp && *svp ? *svp : &PL_sv_undef); - svp++; - } - RETURN; - case OA_AVREF: - if (!numargs) { - GV *gv; - if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) - gv = PL_argvgv; - else { - S_maybe_unwind_defav(aTHX); - gv = PL_defgv; - } - PUSHs((SV *)GvAVn(gv)); - break; - } - if (!svp || !*svp || !SvROK(*svp) - || SvTYPE(SvRV(*svp)) != SVt_PVAV) - DIE(aTHX_ - /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ - "Type of arg %d to &CORE::%s must be array reference", - whicharg, PL_op_desc[opnum] - ); - PUSHs(SvRV(*svp)); - break; - case OA_HVREF: - if (!svp || !*svp || !SvROK(*svp) - || ( SvTYPE(SvRV(*svp)) != SVt_PVHV - && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN - || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) - DIE(aTHX_ - /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ - "Type of arg %d to &CORE::%s must be hash%s reference", - whicharg, PL_op_desc[opnum], - opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN - ? "" - : " or array" - ); - PUSHs(SvRV(*svp)); - break; - case OA_FILEREF: - if (!numargs) PUSHs(NULL); - else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) - /* no magic here, as the prototype will have added an extra - refgen and we just want what was there before that */ - PUSHs(SvRV(*svp)); - else { - const bool constr = PL_op->op_private & whicharg; - PUSHs(S_rv2gv(aTHX_ - svp && *svp ? *svp : &PL_sv_undef, - constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), - !constr - )); - } - break; - case OA_SCALARREF: - if (!numargs) goto try_defsv; - else { - const bool wantscalar = - PL_op->op_private & OPpCOREARGS_SCALARMOD; - if (!svp || !*svp || !SvROK(*svp) - /* We have to permit globrefs even for the \$ proto, as - *foo is indistinguishable from ${\*foo}, and the proto- - type permits the latter. */ - || SvTYPE(SvRV(*svp)) > ( - wantscalar ? SVt_PVLV - : opnum == OP_LOCK || opnum == OP_UNDEF - ? SVt_PVCV - : SVt_PVHV - ) - ) - DIE(aTHX_ - "Type of arg %d to &CORE::%s must be %s", - whicharg, PL_op_name[opnum], - wantscalar - ? "scalar reference" - : opnum == OP_LOCK || opnum == OP_UNDEF - ? "reference to one of [$@%&*]" - : "reference to one of [$@%*]" - ); - PUSHs(SvRV(*svp)); - if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { - /* Undo @_ localisation, so that sub exit does not undo - part of our undeffing. */ - S_maybe_unwind_defav(aTHX); - } - } - break; - default: - DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7)); - } - oa = oa >> 4; + whicharg++; + switch (oa & 7) { + case OA_SCALAR: + try_defsv: + if (!numargs && defgv && whicharg == minargs + 1) { + PUSHs(DEFSV); + } + else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); + break; + case OA_LIST: + while (numargs--) { + PUSHs(svp && *svp ? *svp : &PL_sv_undef); + svp++; + } + RETURN; + case OA_AVREF: + if (!numargs) { + GV *gv; + if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) + gv = PL_argvgv; + else { + S_maybe_unwind_defav(aTHX); + gv = PL_defgv; + } + PUSHs((SV *)GvAVn(gv)); + break; + } + if (!svp || !*svp || !SvROK(*svp) + || SvTYPE(SvRV(*svp)) != SVt_PVAV) + DIE(aTHX_ + /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ + "Type of arg %d to &CORE::%s must be array reference", + whicharg, PL_op_desc[opnum] + ); + PUSHs(SvRV(*svp)); + break; + case OA_HVREF: + if (!svp || !*svp || !SvROK(*svp) + || ( SvTYPE(SvRV(*svp)) != SVt_PVHV + && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN + || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) + DIE(aTHX_ + /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ + "Type of arg %d to &CORE::%s must be hash%s reference", + whicharg, PL_op_desc[opnum], + opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN + ? "" + : " or array" + ); + PUSHs(SvRV(*svp)); + break; + case OA_FILEREF: + if (!numargs) PUSHs(NULL); + else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) + /* no magic here, as the prototype will have added an extra + refgen and we just want what was there before that */ + PUSHs(SvRV(*svp)); + else { + const bool constr = PL_op->op_private & whicharg; + PUSHs(S_rv2gv(aTHX_ + svp && *svp ? *svp : &PL_sv_undef, + constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), + !constr + )); + } + break; + case OA_SCALARREF: + if (!numargs) goto try_defsv; + else { + const bool wantscalar = + PL_op->op_private & OPpCOREARGS_SCALARMOD; + if (!svp || !*svp || !SvROK(*svp) + /* We have to permit globrefs even for the \$ proto, as + *foo is indistinguishable from ${\*foo}, and the proto- + type permits the latter. */ + || SvTYPE(SvRV(*svp)) > ( + wantscalar ? SVt_PVLV + : opnum == OP_LOCK || opnum == OP_UNDEF + ? SVt_PVCV + : SVt_PVHV + ) + ) + DIE(aTHX_ + "Type of arg %d to &CORE::%s must be %s", + whicharg, PL_op_name[opnum], + wantscalar + ? "scalar reference" + : opnum == OP_LOCK || opnum == OP_UNDEF + ? "reference to one of [$@%&*]" + : "reference to one of [$@%*]" + ); + PUSHs(SvRV(*svp)); + if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { + /* Undo @_ localisation, so that sub exit does not undo + part of our undeffing. */ + S_maybe_unwind_defav(aTHX); + } + } + break; + default: + DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7)); + } + oa = oa >> 4; } RETURN; @@ -6687,9 +6687,9 @@ PP(pp_avhvswitch) { dSP; return PL_ppaddr[ - (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) - + (PL_op->op_private & OPpAVHVSWITCH_MASK) - ](aTHX); + (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) + + (PL_op->op_private & OPpAVHVSWITCH_MASK) + ](aTHX); } PP(pp_runcv) @@ -6697,7 +6697,7 @@ PP(pp_runcv) dSP; CV *cv; if (PL_op->op_private & OPpOFFBYONE) { - cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); + cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); } else cv = find_runcv(NULL); XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv))); @@ -6706,49 +6706,49 @@ PP(pp_runcv) static void S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv, - const bool can_preserve) + const bool can_preserve) { const SSize_t ix = SvIV(keysv); if (can_preserve ? av_exists(av, ix) : TRUE) { - SV ** const svp = av_fetch(av, ix, 1); - if (!svp || !*svp) - Perl_croak(aTHX_ PL_no_aelem, ix); - save_aelem(av, ix, svp); + SV ** const svp = av_fetch(av, ix, 1); + if (!svp || !*svp) + Perl_croak(aTHX_ PL_no_aelem, ix); + save_aelem(av, ix, svp); } else - SAVEADELETE(av, ix); + SAVEADELETE(av, ix); } static void S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv, - const bool can_preserve) + const bool can_preserve) { if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) { - HE * const he = hv_fetch_ent(hv, keysv, 1, 0); - SV ** const svp = he ? &HeVAL(he) : NULL; - if (!svp || !*svp) - Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); - save_helem_flags(hv, keysv, svp, 0); + HE * const he = hv_fetch_ent(hv, keysv, 1, 0); + SV ** const svp = he ? &HeVAL(he) : NULL; + if (!svp || !*svp) + Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + save_helem_flags(hv, keysv, svp, 0); } else - SAVEHDELETE(hv, keysv); + SAVEHDELETE(hv, keysv); } static void S_localise_gv_slot(pTHX_ GV *gv, U8 type) { if (type == OPpLVREF_SV) { - save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); - GvSV(gv) = 0; + save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); + GvSV(gv) = 0; } else if (type == OPpLVREF_AV) - /* XXX Inefficient, as it creates a new AV, which we are - about to clobber. */ - save_ary(gv); + /* XXX Inefficient, as it creates a new AV, which we are + about to clobber. */ + save_ary(gv); else { - assert(type == OPpLVREF_HV); - /* XXX Likewise inefficient. */ - save_hash(gv); + assert(type == OPpLVREF_HV); + /* XXX Likewise inefficient. */ + save_hash(gv); } } @@ -6764,63 +6764,63 @@ PP(pp_refassign) if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); switch (type) { case OPpLVREF_SV: - if (SvTYPE(SvRV(sv)) > SVt_PVLV) - bad = " SCALAR"; - break; + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; case OPpLVREF_AV: - if (SvTYPE(SvRV(sv)) != SVt_PVAV) - bad = "n ARRAY"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; case OPpLVREF_HV: - if (SvTYPE(SvRV(sv)) != SVt_PVHV) - bad = " HASH"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; case OPpLVREF_CV: - if (SvTYPE(SvRV(sv)) != SVt_PVCV) - bad = " CODE"; + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; } if (bad) - /* diag_listed_as: Assigned value is not %s reference */ - DIE(aTHX_ "Assigned value is not a%s reference", bad); + /* diag_listed_as: Assigned value is not %s reference */ + DIE(aTHX_ "Assigned value is not a%s reference", bad); { MAGIC *mg; HV *stash; switch (left ? SvTYPE(left) : 0) { case 0: { - SV * const old = PAD_SV(ARGTARG); - PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); - SvREFCNT_dec(old); - if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) - == OPpLVAL_INTRO) - SAVECLEARSV(PAD_SVl(ARGTARG)); - break; + SV * const old = PAD_SV(ARGTARG); + PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); + SvREFCNT_dec(old); + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == OPpLVAL_INTRO) + SAVECLEARSV(PAD_SVl(ARGTARG)); + break; } case SVt_PVGV: - if (PL_op->op_private & OPpLVAL_INTRO) { - S_localise_gv_slot(aTHX_ (GV *)left, type); - } - gv_setref(left, sv); - SvSETMAGIC(left); - break; + if (PL_op->op_private & OPpLVAL_INTRO) { + S_localise_gv_slot(aTHX_ (GV *)left, type); + } + gv_setref(left, sv); + SvSETMAGIC(left); + break; case SVt_PVAV: assert(key); - if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { - S_localise_aelem_lval(aTHX_ (AV *)left, key, - SvCANEXISTDELETE(left)); - } - av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); - break; + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { + S_localise_aelem_lval(aTHX_ (AV *)left, key, + SvCANEXISTDELETE(left)); + } + av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); + break; case SVt_PVHV: if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { assert(key); - S_localise_helem_lval(aTHX_ (HV *)left, key, - SvCANEXISTDELETE(left)); + S_localise_helem_lval(aTHX_ (HV *)left, key, + SvCANEXISTDELETE(left)); } - (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); + (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); } if (PL_op->op_flags & OPf_MOD) - SETs(sv_2mortal(newSVsv(sv))); + SETs(sv_2mortal(newSVsv(sv))); /* XXX else can weak references go stale before they are read, e.g., in leavesub? */ RETURN; @@ -6834,11 +6834,11 @@ PP(pp_lvref) SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref, - &PL_vtbl_lvref, (char *)elem, - elem ? HEf_SVKEY : (I32)ARGTARG); + &PL_vtbl_lvref, (char *)elem, + elem ? HEf_SVKEY : (I32)ARGTARG); mg->mg_private = PL_op->op_private; if (PL_op->op_private & OPpLVREF_ITER) - mg->mg_flags |= MGf_PERSIST; + mg->mg_flags |= MGf_PERSIST; if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { if (elem) { MAGIC *mg; @@ -6853,11 +6853,11 @@ PP(pp_lvref) } } else if (arg) { - S_localise_gv_slot(aTHX_ (GV *)arg, - PL_op->op_private & OPpLVREF_TYPE); + S_localise_gv_slot(aTHX_ (GV *)arg, + PL_op->op_private & OPpLVREF_TYPE); } else if (!(PL_op->op_private & OPpPAD_STATE)) - SAVECLEARSV(PAD_SVl(ARGTARG)); + SAVECLEARSV(PAD_SVl(ARGTARG)); } XPUSHs(ret); RETURN; @@ -6871,35 +6871,35 @@ PP(pp_lvrefslice) bool can_preserve = FALSE; if (UNLIKELY(localizing)) { - MAGIC *mg; - HV *stash; - SV **svp; + MAGIC *mg; + HV *stash; + SV **svp; - can_preserve = SvCANEXISTDELETE(av); + can_preserve = SvCANEXISTDELETE(av); - if (SvTYPE(av) == SVt_PVAV) { - SSize_t max = -1; + if (SvTYPE(av) == SVt_PVAV) { + SSize_t max = -1; - for (svp = MARK + 1; svp <= SP; svp++) { - const SSize_t elem = SvIV(*svp); - if (elem > max) - max = elem; - } - if (max > AvMAX(av)) - av_extend(av, max); - } + for (svp = MARK + 1; svp <= SP; svp++) { + const SSize_t elem = SvIV(*svp); + if (elem > max) + max = elem; + } + if (max > AvMAX(av)) + av_extend(av, max); + } } while (++MARK <= SP) { - SV * const elemsv = *MARK; + SV * const elemsv = *MARK; if (UNLIKELY(localizing)) { if (SvTYPE(av) == SVt_PVAV) S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve); else S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve); } - *MARK = sv_2mortal(newSV_type(SVt_PVMG)); - sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); + *MARK = sv_2mortal(newSV_type(SVt_PVMG)); + sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); } RETURN; } @@ -6907,15 +6907,15 @@ PP(pp_lvrefslice) PP(pp_lvavref) { if (PL_op->op_flags & OPf_STACKED) - Perl_pp_rv2av(aTHX); + Perl_pp_rv2av(aTHX); else - Perl_pp_padav(aTHX); + Perl_pp_padav(aTHX); { - dSP; - dTOPss; - SETs(0); /* special alias marker that aassign recognises */ - XPUSHs(sv); - RETURN; + dSP; + dTOPss; + SETs(0); /* special alias marker that aassign recognises */ + XPUSHs(sv); + RETURN; } } @@ -6924,9 +6924,9 @@ PP(pp_anonconst) dSP; dTOPss; SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV - ? CopSTASH(PL_curcop) - : NULL, - NULL, SvREFCNT_inc_simple_NN(sv)))); + ? CopSTASH(PL_curcop) + : NULL, + NULL, SvREFCNT_inc_simple_NN(sv)))); RETURN; } @@ -7196,10 +7196,10 @@ PP(pp_cmpchain_and) SV *result = POPs; PUTBACK; if (SvTRUE_NN(result)) { - return cLOGOP->op_other; + return cLOGOP->op_other; } else { - TOPs = result; - return NORMAL; + TOPs = result; + return NORMAL; } } diff --git a/regcomp.c b/regcomp.c index f5e5f581dc7e..3adeb8c30b3b 100644 --- a/regcomp.c +++ b/regcomp.c @@ -224,11 +224,11 @@ struct RExC_state_t { regnode *end_op; /* END node in program */ I32 utf8; /* whether the pattern is utf8 or not */ I32 orig_utf8; /* whether the pattern was originally in utf8 */ - /* XXX use this for future optimisation of case - * where pattern must be upgraded to utf8. */ + /* XXX use this for future optimisation of case + * where pattern must be upgraded to utf8. */ I32 uni_semantics; /* If a d charset modifier should use unicode - rules, even if the pattern is not in - utf8 */ + rules, even if the pattern is not in + utf8 */ I32 recurse_count; /* Number of recurse regops we have generated */ regnode **recurse; /* Recurse regops */ @@ -242,7 +242,7 @@ struct RExC_state_t { I32 in_multi_char_class; int code_index; /* next code_blocks[] slot */ struct reg_code_blocks *code_blocks;/* positions of literal (?{}) - within pattern */ + within pattern */ SSize_t maxlen; /* mininum possible number of chars in string to match */ scan_frame *frame_head; scan_frame *frame_last; @@ -802,23 +802,23 @@ static const scan_data_t zero_scan_data = { #define _FAIL(code) STMT_START { \ const char *ellipses = ""; \ IV len = RExC_precomp_end - RExC_precomp; \ - \ + \ PREPARE_TO_DIE; \ if (len > RegexLengthToShowInErrorMessages) { \ - /* chop 10 shorter than the max, to ensure meaning of "..." */ \ - len = RegexLengthToShowInErrorMessages - 10; \ - ellipses = "..."; \ + /* chop 10 shorter than the max, to ensure meaning of "..." */ \ + len = RegexLengthToShowInErrorMessages - 10; \ + ellipses = "..."; \ } \ code; \ } STMT_END #define FAIL(msg) _FAIL( \ Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/", \ - msg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) + msg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) #define FAIL2(msg,arg) _FAIL( \ Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \ - arg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) + arg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) #define FAIL3(msg,arg1,arg2) _FAIL( \ Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \ @@ -829,7 +829,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL(m) STMT_START { \ Perl_croak(aTHX_ "%s" REPORT_LOCATION, \ - m, REPORT_LOCATION_ARGS(RExC_parse)); \ + m, REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END /* @@ -862,7 +862,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL3(m, a1, a2) STMT_START { \ S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, \ - REPORT_LOCATION_ARGS(RExC_parse)); \ + REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END /* @@ -878,7 +878,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \ S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, a3, \ - REPORT_LOCATION_ARGS(RExC_parse)); \ + REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END #define vFAIL4(m,a1,a2,a3) STMT_START { \ @@ -969,7 +969,7 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + REPORT_LOCATION_ARGS(loc))) #define vWARN(loc, m) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ @@ -981,26 +981,26 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), \ m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + REPORT_LOCATION_ARGS(loc))) #define ckWARNdep(loc,m) \ _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ - m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + REPORT_LOCATION_ARGS(loc))) #define ckWARNregdep(loc,m) \ _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, \ WARN_REGEXP), \ - m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + REPORT_LOCATION_ARGS(loc))) #define ckWARN2reg_d(loc,m, a1) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ - m REPORT_LOCATION, \ - a1, REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + a1, REPORT_LOCATION_ARGS(loc))) #define ckWARN2reg(loc, m, a1) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ @@ -1012,34 +1012,34 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, REPORT_LOCATION_ARGS(loc))) + a1, a2, REPORT_LOCATION_ARGS(loc))) #define ckWARN3reg(loc, m, a1, a2) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, \ + a1, a2, \ REPORT_LOCATION_ARGS(loc))) #define vWARN4(loc, m, a1, a2, a3) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, \ + a1, a2, a3, \ REPORT_LOCATION_ARGS(loc))) #define ckWARN4reg(loc, m, a1, a2, a3) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, \ + a1, a2, a3, \ REPORT_LOCATION_ARGS(loc))) #define vWARN5(loc, m, a1, a2, a3, a4) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, a4, \ + a1, a2, a3, a4, \ REPORT_LOCATION_ARGS(loc))) #define ckWARNexperimental(loc, class, m) \ @@ -1081,14 +1081,14 @@ static const scan_data_t zero_scan_data = { #define ProgLen(ri) ri->u.offsets[0] #define SetProgLen(ri,x) ri->u.offsets[0] = x #define Set_Node_Offset_To_R(offset,byte) STMT_START { \ - MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ - __LINE__, (int)(offset), (int)(byte))); \ - if((offset) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Offset macro", \ + MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ + __LINE__, (int)(offset), (int)(byte))); \ + if((offset) < 0) { \ + Perl_croak(aTHX_ "value of node is %d in Offset macro", \ (int)(offset)); \ - } else { \ + } else { \ RExC_offsets[2*(offset)-1] = (byte); \ - } \ + } \ } STMT_END #define Set_Node_Offset(node,byte) \ @@ -1096,14 +1096,14 @@ static const scan_data_t zero_scan_data = { #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse) #define Set_Node_Length_To_R(node,len) STMT_START { \ - MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \ - __LINE__, (int)(node), (int)(len))); \ - if((node) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Length macro", \ + MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \ + __LINE__, (int)(node), (int)(len))); \ + if((node) < 0) { \ + Perl_croak(aTHX_ "value of node is %d in Length macro", \ (int)(node)); \ - } else { \ - RExC_offsets[2*(node)] = (len); \ - } \ + } else { \ + RExC_offsets[2*(node)] = (len); \ + } \ } STMT_END #define Set_Node_Length(node,len) \ @@ -1477,13 +1477,13 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) { const U8 i = data->cur_is_floating; - SvSetMagicSV(longest_sv, data->last_found); + SvSetMagicSV(longest_sv, data->last_found); data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min; - if (!i) /* fixed */ - data->substrs[0].max_offset = data->substrs[0].min_offset; - else { /* float */ - data->substrs[1].max_offset = + if (!i) /* fixed */ + data->substrs[0].max_offset = data->substrs[0].min_offset; + else { /* float */ + data->substrs[1].max_offset = (is_inf) ? OPTIMIZE_INFTY : (l @@ -1491,8 +1491,8 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, /* temporary underflow guard for 5.32 */ : data->pos_delta < 0 ? OPTIMIZE_INFTY : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min - ? OPTIMIZE_INFTY - : data->pos_min + data->pos_delta)); + ? OPTIMIZE_INFTY + : data->pos_min + data->pos_delta)); } data->substrs[i].flags &= ~SF_BEFORE_EOL; @@ -1503,12 +1503,12 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, SvCUR_set(data->last_found, 0); { - SV * const sv = data->last_found; - if (SvUTF8(sv) && SvMAGICAL(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8); - if (mg) - mg->mg_len = 0; - } + SV * const sv = data->last_found; + if (SvUTF8(sv) && SvMAGICAL(sv)) { + MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8); + if (mg) + mg->mg_len = 0; + } } data->last_end = -1; data->flags &= ~SF_BEFORE_EOL; @@ -1597,10 +1597,10 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) * test cases for locale, many parts of it may not work properly, it is * safest to avoid locale unless necessary. */ if (RExC_contains_locale) { - ANYOF_POSIXL_SETALL(ssc); + ANYOF_POSIXL_SETALL(ssc); } else { - ANYOF_POSIXL_ZERO(ssc); + ANYOF_POSIXL_ZERO(ssc); } } @@ -2255,7 +2255,7 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, - AV *revcharmap, U32 depth) + AV *revcharmap, U32 depth) { U32 state; SV *sv=sv_newmortal(); @@ -2269,14 +2269,14 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, depth+1, "Match","Base","Ofs" ); for( state = 0 ; state < trie->uniquecharcount ; state++ ) { - SV ** const tmp = av_fetch( revcharmap, state, 0); + SV ** const tmp = av_fetch( revcharmap, state, 0); if ( tmp ) { Perl_re_printf( aTHX_ "%*s", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); } @@ -2289,7 +2289,7 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, Perl_re_printf( aTHX_ "\n"); for( state = 1 ; state < trie->statecount ; state++ ) { - const U32 base = trie->states[ state ].trans.base; + const U32 base = trie->states[ state ].trans.base; Perl_re_indentf( aTHX_ "#%4" UVXf "|", depth+1, (UV)state); @@ -2336,8 +2336,8 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, depth); for (word=1; word <= trie->wordcount; word++) { Perl_re_printf( aTHX_ " %d:(%d,%d)", - (int)word, (int)(trie->wordinfo[word].prev), - (int)(trie->wordinfo[word].len)); + (int)word, (int)(trie->wordinfo[word].prev), + (int)(trie->wordinfo[word].len)); } Perl_re_printf( aTHX_ "\n" ); } @@ -2349,8 +2349,8 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, */ STATIC void S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, - HV *widecharmap, AV *revcharmap, U32 next_alloc, - U32 depth) + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; SV *sv=sv_newmortal(); @@ -2378,9 +2378,9 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, ); } for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) { - SV ** const tmp = av_fetch( revcharmap, + SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state, charid).forid, 0); - if ( tmp ) { + if ( tmp ) { Perl_re_printf( aTHX_ "%*s:%3X=%4" UVXf " | ", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), @@ -2409,8 +2409,8 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, */ STATIC void S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, - HV *widecharmap, AV *revcharmap, U32 next_alloc, - U32 depth) + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; U16 charid; @@ -2428,14 +2428,14 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, Perl_re_indentf( aTHX_ "Char : ", depth+1 ); for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) { - SV ** const tmp = av_fetch( revcharmap, charid, 0); + SV ** const tmp = av_fetch( revcharmap, charid, 0); if ( tmp ) { Perl_re_printf( aTHX_ "%*s", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); } @@ -2480,9 +2480,9 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, /* make_trie(startbranch,first,last,tail,word_count,flags,depth) startbranch: the first branch in the whole branch sequence first : start branch of sequence of branch-exact nodes. - May be the same as startbranch + May be the same as startbranch last : Thing following the last branch. - May be the same as tail. + May be the same as tail. tail : item following the branch sequence count : words in the sequence flags : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/ @@ -2558,10 +2558,10 @@ and should turn into: 1: CURLYM[1] {1,32767}(18) 5: TRIE(16) - [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1] - - - + [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1] + + + 16: SUCCEED(0) 17: NOTHING(18) 18: END(0) @@ -2581,8 +2581,8 @@ and would end up looking like: 1: TRIE(8) [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1] - - + + 7: TAIL(8) 8: EXACT (10) 10: END(0) @@ -2596,19 +2596,19 @@ is the recommended Unicode-aware way of saying #define TRIE_STORE_REVCHAR(val) \ STMT_START { \ - if (UTF) { \ + if (UTF) { \ SV *zlopp = newSV(UTF8_MAXBYTES); \ - unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \ + unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \ unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val); \ *kapow = '\0'; \ - SvCUR_set(zlopp, kapow - flrbbbbb); \ - SvPOK_on(zlopp); \ - SvUTF8_on(zlopp); \ - av_push(revcharmap, zlopp); \ - } else { \ + SvCUR_set(zlopp, kapow - flrbbbbb); \ + SvPOK_on(zlopp); \ + SvUTF8_on(zlopp); \ + av_push(revcharmap, zlopp); \ + } else { \ char ooooff = (char)val; \ - av_push(revcharmap, newSVpvn(&ooooff, 1)); \ - } \ + av_push(revcharmap, newSVpvn(&ooooff, 1)); \ + } \ } STMT_END /* This gets the next character from the input, folding it if not already @@ -2639,8 +2639,8 @@ is the recommended Unicode-aware way of saying #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \ if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \ - U32 ging = TRIE_LIST_LEN( state ) * 2; \ - Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \ + U32 ging = TRIE_LIST_LEN( state ) * 2; \ + Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \ TRIE_LIST_LEN( state ) = ging; \ } \ TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \ @@ -2650,7 +2650,7 @@ is the recommended Unicode-aware way of saying #define TRIE_LIST_NEW(state) STMT_START { \ Newx( trie->states[ state ].trans.list, \ - 4, reg_trie_trans_le ); \ + 4, reg_trie_trans_le ); \ TRIE_LIST_CUR( state ) = 1; \ TRIE_LIST_LEN( state ) = 4; \ } STMT_END @@ -2689,8 +2689,8 @@ is the recommended Unicode-aware way of saying /* It's a dupe. Pre-insert into the wordinfo[].prev */\ /* chain, so that when the bits of chain are later */\ /* linked together, the dups appear in the chain */\ - trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \ - trie->wordinfo[dupe].prev = curword; \ + trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \ + trie->wordinfo[dupe].prev = curword; \ } else { \ /* we haven't inserted this word yet. */ \ trie->states[ state ].wordnum = curword; \ @@ -2770,11 +2770,11 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, switch (flags) { case EXACT: case EXACT_REQ8: case EXACTL: break; - case EXACTFAA: + case EXACTFAA: case EXACTFUP: - case EXACTFU: - case EXACTFLU8: folder = PL_fold_latin1; break; - case EXACTF: folder = PL_fold; break; + case EXACTFU: + case EXACTFLU8: folder = PL_fold_latin1; break; + case EXACTF: folder = PL_fold; break; default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] ); } @@ -2785,7 +2785,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, RExC_rxi->data->data[ data_slot ] = (void*)trie; trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) ); if (flags == EXACT || flags == EXACT_REQ8 || flags == EXACTL) - trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 ); + trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 ); trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc( trie->wordcount+1, sizeof(reg_trie_wordinfo)); @@ -2965,8 +2965,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, TRIE_STORE_REVCHAR( uvc ); } if ( set_bit ) { - /* store the codepoint in the bitmap, and its folded - * equivalent. */ + /* store the codepoint in the bitmap, and its folded + * equivalent. */ TRIE_BITMAP_SET_FOLDED(trie, uvc, folder); set_bit = 0; /* We've done our bit :-) */ } @@ -3011,8 +3011,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n", depth+1, ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count, - (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, - (int)trie->minlen, (int)trie->maxlen ) + (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, + (int)trie->minlen, (int)trie->maxlen ) ); /* @@ -3060,17 +3060,17 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using list compiler\n", depth+1)); - trie->states = (reg_trie_state *) - PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, - sizeof(reg_trie_state) ); + trie->states = (reg_trie_state *) + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); TRIE_LIST_NEW(1); next_alloc = 2; for ( cur = first ; cur < last ; cur = regnext( cur ) ) { regnode *noper = NEXTOPER( cur ); - U32 state = 1; /* required init */ - U16 charid = 0; /* sanity init */ + U32 state = 1; /* required init */ + U16 charid = 0; /* sanity init */ U32 wordlen = 0; /* required init */ if (OP(noper) == NOTHING) { @@ -3097,7 +3097,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; - } else { + } else { SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), @@ -3107,7 +3107,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } else { charid=(U16)SvIV( *svpp ); } - } + } /* charid is now 0 if we dont know the char read, or * nonzero if we do */ if ( charid ) { @@ -3118,7 +3118,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, charid--; if ( !trie->states[ state ].trans.list ) { TRIE_LIST_NEW( state ); - } + } for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) @@ -3132,15 +3132,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } if ( ! newstate ) { newstate = next_alloc++; - prev_states[newstate] = state; + prev_states[newstate] = state; TRIE_LIST_PUSH( state, charid, newstate ); transcount++; } state = newstate; } else { Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc ); - } - } + } + } } else { /* If we end up here it is because we skipped past a NOTHING, but did not end up * on a trieable type. So we need to reset noper back to point at the first regop @@ -3155,18 +3155,18 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, /* next alloc is the NEXT state to be allocated */ trie->statecount = next_alloc; trie->states = (reg_trie_state *) - PerlMemShared_realloc( trie->states, - next_alloc - * sizeof(reg_trie_state) ); + PerlMemShared_realloc( trie->states, + next_alloc + * sizeof(reg_trie_state) ); /* and now dump it out before we compress it */ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap, - revcharmap, next_alloc, - depth+1) + revcharmap, next_alloc, + depth+1) ); trie->trans = (reg_trie_trans *) - PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); + PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); { U32 state; U32 tp = 0; @@ -3185,22 +3185,22 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if (trie->states[state].trans.list) { U16 minid=TRIE_LIST_ITEM( state, 1).forid; U16 maxid=minid; - U16 idx; + U16 idx; for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) { - const U16 forid = TRIE_LIST_ITEM( state, idx).forid; - if ( forid < minid ) { - minid=forid; - } else if ( forid > maxid ) { - maxid=forid; - } + const U16 forid = TRIE_LIST_ITEM( state, idx).forid; + if ( forid < minid ) { + minid=forid; + } else if ( forid > maxid ) { + maxid=forid; + } } if ( transcount < tp + maxid - minid + 1) { transcount *= 2; - trie->trans = (reg_trie_trans *) - PerlMemShared_realloc( trie->trans, - transcount - * sizeof(reg_trie_trans) ); + trie->trans = (reg_trie_trans *) + PerlMemShared_realloc( trie->trans, + transcount + * sizeof(reg_trie_trans) ); Zero( trie->trans + (transcount / 2), transcount / 2, reg_trie_trans ); @@ -3286,13 +3286,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using table compiler\n", depth+1)); - trie->trans = (reg_trie_trans *) - PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) - * trie->uniquecharcount + 1, - sizeof(reg_trie_trans) ); + trie->trans = (reg_trie_trans *) + PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) + * trie->uniquecharcount + 1, + sizeof(reg_trie_trans) ); trie->states = (reg_trie_state *) - PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, - sizeof(reg_trie_state) ); + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); next_alloc = trie->uniquecharcount + 1; @@ -3343,8 +3343,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if ( !trie->trans[ state + charid ].next ) { trie->trans[ state + charid ].next = next_alloc; trie->trans[ state ].check++; - prev_states[TRIE_NODENUM(next_alloc)] - = TRIE_NODENUM(state); + prev_states[TRIE_NODENUM(next_alloc)] + = TRIE_NODENUM(state); next_alloc += trie->uniquecharcount; } state = trie->trans[ state + charid ].next; @@ -3368,8 +3368,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, /* and now dump it out before we compress it */ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap, - revcharmap, - next_alloc, depth+1)); + revcharmap, + next_alloc, depth+1)); { /* @@ -3434,15 +3434,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, demq */ const U32 laststate = TRIE_NODENUM( next_alloc ); - U32 state, charid; + U32 state, charid; U32 pos = 0, zp=0; trie->statecount = laststate; for ( state = 1 ; state < laststate ; state++ ) { U8 flag = 0; - const U32 stateidx = TRIE_NODEIDX( state ); - const U32 o_used = trie->trans[ stateidx ].check; - U32 used = trie->trans[ stateidx ].check; + const U32 stateidx = TRIE_NODEIDX( state ); + const U32 o_used = trie->trans[ stateidx ].check; + U32 used = trie->trans[ stateidx ].check; trie->trans[ stateidx ].check = 0; for ( charid = 0; @@ -3485,8 +3485,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } trie->lasttrans = pos + 1; trie->states = (reg_trie_state *) - PerlMemShared_realloc( trie->states, laststate - * sizeof(reg_trie_state) ); + PerlMemShared_realloc( trie->states, laststate + * sizeof(reg_trie_state) ); DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n", depth+1, @@ -3507,8 +3507,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, ); /* resize the trans array to remove unused space */ trie->trans = (reg_trie_trans *) - PerlMemShared_realloc( trie->trans, trie->lasttrans - * sizeof(reg_trie_trans) ); + PerlMemShared_realloc( trie->trans, trie->lasttrans + * sizeof(reg_trie_trans) ); { /* Modify the program and insert the new TRIE node */ U8 nodetype =(U8)(flags & 0xFF); @@ -3603,20 +3603,20 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, (UV)state)); if (first_ofs >= 0) { SV ** const tmp = av_fetch( revcharmap, first_ofs, 0); - const U8 * const ch = (U8*)SvPV_nolen_const( *tmp ); + const U8 * const ch = (U8*)SvPV_nolen_const( *tmp ); TRIE_BITMAP_SET_FOLDED(trie,*ch, folder); DEBUG_OPTIMISE_r( Perl_re_printf( aTHX_ "%s", (char*)ch) ); - } - } + } + } /* store the current firstchar in the bitmap */ TRIE_BITMAP_SET_FOLDED(trie,*ch, folder); DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch)); - } + } first_ofs = ofs; - } + } } if ( count == 1 ) { /* This state has only one transition, its transition is part @@ -3631,9 +3631,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, depth+1, (UV)state, (UV)first_ofs, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); }); @@ -3646,15 +3646,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, setSTR_LEN(convert, (U8)(STR_LEN(convert) + len)); while (len--) *str++ = *ch++; - } else { + } else { #ifdef DEBUGGING - if (state>1) + if (state>1) DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n")); #endif - break; - } - } - trie->prefixlen = (state-1); + break; + } + } + trie->prefixlen = (state-1); if (str) { regnode *n = convert+NODE_SZ_STR(convert); assert( NODE_SZ_STR(convert) <= U16_MAX ); @@ -3695,7 +3695,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, #endif if (trie->maxlen) { convert = n; - } else { + } else { NEXT_OFF(convert) = (U16)(tail - convert); DEBUG_r(optimize= n); } @@ -3704,23 +3704,23 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if (!jumper) jumper = last; if ( trie->maxlen ) { - NEXT_OFF( convert ) = (U16)(tail - convert); - ARG_SET( convert, data_slot ); - /* Store the offset to the first unabsorbed branch in - jump[0], which is otherwise unused by the jump logic. - We use this when dumping a trie and during optimisation. */ - if (trie->jump) - trie->jump[0] = (U16)(nextbranch - convert); + NEXT_OFF( convert ) = (U16)(tail - convert); + ARG_SET( convert, data_slot ); + /* Store the offset to the first unabsorbed branch in + jump[0], which is otherwise unused by the jump logic. + We use this when dumping a trie and during optimisation. */ + if (trie->jump) + trie->jump[0] = (U16)(nextbranch - convert); /* If the start state is not accepting (meaning there is no empty string/NOTHING) - * and there is a bitmap - * and the first "jump target" node we found leaves enough room - * then convert the TRIE node into a TRIEC node, with the bitmap - * embedded inline in the opcode - this is hypothetically faster. - */ + * and there is a bitmap + * and the first "jump target" node we found leaves enough room + * then convert the TRIE node into a TRIEC node, with the bitmap + * embedded inline in the opcode - this is hypothetically faster. + */ if ( !trie->states[trie->startstate].wordnum - && trie->bitmap - && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) ) + && trie->bitmap + && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) ) { OP( convert ) = TRIEC; Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char); @@ -3769,26 +3769,26 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, * already linked up earlier. */ { - U16 word; - U32 state; - U16 prev; - - for (word=1; word <= trie->wordcount; word++) { - prev = 0; - if (trie->wordinfo[word].prev) - continue; - state = trie->wordinfo[word].accept; - while (state) { - state = prev_states[state]; - if (!state) - break; - prev = trie->states[state].wordnum; - if (prev) - break; - } - trie->wordinfo[word].prev = prev; - } - Safefree(prev_states); + U16 word; + U32 state; + U16 prev; + + for (word=1; word <= trie->wordcount; word++) { + prev = 0; + if (trie->wordinfo[word].prev) + continue; + state = trie->wordinfo[word].accept; + while (state) { + state = prev_states[state]; + if (!state) + break; + prev = trie->states[state].wordnum; + if (prev) + break; + } + trie->wordinfo[word].prev = prev; + } + Safefree(prev_states); } @@ -3885,20 +3885,20 @@ S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *sour fail[ 0 ] = fail[ 1 ] = 1; for ( charid = 0; charid < ucharcount ; charid++ ) { - const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 ); - if ( newstate ) { + const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 ); + if ( newstate ) { q[ q_write ] = newstate; /* set to point at the root */ fail[ q[ q_write++ ] ]=1; } } while ( q_read < q_write) { - const U32 cur = q[ q_read++ % numstates ]; + const U32 cur = q[ q_read++ % numstates ]; base = trie->states[ cur ].trans.base; for ( charid = 0 ; charid < ucharcount ; charid++ ) { - const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ); - if (ch_state) { + const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ); + if (ch_state) { U32 fail_state = cur; U32 fail_base; do { @@ -4260,16 +4260,16 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, } #ifdef EXPERIMENTAL_INPLACESCAN - if (flags && !NEXT_OFF(n)) { - DEBUG_PEEP("atch", val, depth, 0); - if (reg_off_by_arg[OP(n)]) { - ARG_SET(n, val - n); - } - else { - NEXT_OFF(n) = val - n; - } - stopnow = 1; - } + if (flags && !NEXT_OFF(n)) { + DEBUG_PEEP("atch", val, depth, 0); + if (reg_off_by_arg[OP(n)]) { + ARG_SET(n, val - n); + } + else { + NEXT_OFF(n) = val - n; + } + stopnow = 1; + } #endif } @@ -4295,11 +4295,11 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, int total_count_delta = 0; /* Total delta number of characters that multi-char folds expand to */ - /* One pass is made over the node's string looking for all the - * possibilities. To avoid some tests in the loop, there are two main - * cases, for UTF-8 patterns (which can't have EXACTF nodes) and - * non-UTF-8 */ - if (UTF) { + /* One pass is made over the node's string looking for all the + * possibilities. To avoid some tests in the loop, there are two main + * cases, for UTF-8 patterns (which can't have EXACTF nodes) and + * non-UTF-8 */ + if (UTF) { U8* folded = NULL; if (OP(scan) == EXACTFL) { @@ -4356,7 +4356,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * executed */ while (s < s_end - 1) /* Can stop 1 before the end, as minimum length sequence we are looking for is 2 */ - { + { int count = 0; /* How many characters in a multi-char fold */ int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end); if (! len) { /* Not a multi-char fold: get next char */ @@ -4392,7 +4392,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * the character that folds to the sequence is) */ total_count_delta += count - 1; next_iteration: ; - } + } /* We created a temporary folded copy of the string in EXACTFL * nodes. Therefore we need to be sure it doesn't go below zero, @@ -4407,8 +4407,8 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, *min_subtract += total_count_delta; Safefree(folded); - } - else if (OP(scan) == EXACTFAA) { + } + else if (OP(scan) == EXACTFAA) { /* Non-UTF-8 pattern, EXACTFAA node. There can't be a multi-char * fold to the ASCII range (and there are no existing ones in the @@ -4419,7 +4419,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ || UNICODE_DOT_DOT_VERSION > 0) - while (s < s_end) { + while (s < s_end) { if (*s == LATIN_SMALL_LETTER_SHARP_S) { OP(scan) = EXACTFAA_NO_TRIE; *unfolded_multi_char = TRUE; @@ -4428,7 +4428,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, s++; } } - else if (OP(scan) != EXACTFAA_NO_TRIE) { + else if (OP(scan) != EXACTFAA_NO_TRIE) { /* Non-UTF-8 pattern, not EXACTFAA node. Look for the multi-char * folds that are all Latin1. As explained in the comments @@ -4436,11 +4436,11 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * and EXACTFL nodes; it can be in the final position. Otherwise * we can stop looking 1 byte earlier because have to find at least * two characters for a multi-fold */ - const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL) + const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL) ? s_end : s_end -1; - while (s < upper) { + while (s < upper) { int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end); if (! len) { /* Not a multi-char fold. */ if (*s == LATIN_SMALL_LETTER_SHARP_S @@ -4466,13 +4466,13 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, if (OP(scan) != EXACTF && OP(scan) != EXACTFL) { OP(scan) = EXACTFUP; } - } + } *min_subtract += len - 1; s += len; - } + } #endif - } + } } #ifdef DEBUGGING @@ -4480,9 +4480,9 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * ops and/or strings with fake optimized ops */ n = scan + NODE_SZ_STR(scan); while (n <= stop) { - OP(n) = OPTIMIZED; - FLAGS(n) = 0; - NEXT_OFF(n) = 0; + OP(n) = OPTIMIZED; + FLAGS(n) = 0; + NEXT_OFF(n) = 0; n++; } #endif @@ -4553,19 +4553,19 @@ S_rck_elide_nothing(pTHX_ regnode *node) STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, - regnode *last, - scan_data_t *data, - I32 stopparen, + regnode *last, + scan_data_t *data, + I32 stopparen, U32 recursed_depth, - regnode_ssc *and_withp, - U32 flags, U32 depth, bool was_mutate_ok) - /* scanp: Start here (read-write). */ - /* deltap: Write maxlen-minlen here. */ - /* last: Stop before this one. */ - /* data: string data about the pattern */ - /* stopparen: treat close N as END */ - /* recursed: which subroutines have we recursed into */ - /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ + regnode_ssc *and_withp, + U32 flags, U32 depth, bool was_mutate_ok) + /* scanp: Start here (read-write). */ + /* deltap: Write maxlen-minlen here. */ + /* last: Stop before this one. */ + /* data: string data about the pattern */ + /* stopparen: treat close N as END */ + /* recursed: which subroutines have we recursed into */ + /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ { SSize_t final_minlen; /* There must be at least this number of characters to match */ @@ -4628,12 +4628,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, UV min_subtract = 0; /* How mmany chars to subtract from the minimum node length to get a real minimum (because the folded version may be shorter) */ - bool unfolded_multi_char = FALSE; + bool unfolded_multi_char = FALSE; /* avoid mutating ops if we are anywhere within the recursed or * enframed handling for a GOSUB: the outermost level will handle it. */ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub); - /* Peephole optimizer: */ + /* Peephole optimizer: */ DEBUG_STUDYDATA("Peep", data, depth, is_inf); DEBUG_PEEP("Peep", scan, depth, flags); @@ -4691,21 +4691,21 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, OP(scan) == BRANCHJ || OP(scan) == IFTHEN ) { - next = regnext(scan); - code = OP(scan); + next = regnext(scan); + code = OP(scan); /* The op(next)==code check below is to see if we * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN" * IFTHEN is special as it might not appear in pairs. * Not sure whether BRANCH-BRANCHJ is possible, regardless * we dont handle it cleanly. */ - if (OP(next) == code || code == IFTHEN) { + if (OP(next) == code || code == IFTHEN) { /* NOTE - There is similar code to this block below for * handling TRIE nodes on a re-study. If you change stuff here * check there too. */ - SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0; - regnode_ssc accum; - regnode * const startbranch=scan; + SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0; + regnode_ssc accum; + regnode * const startbranch=scan; if (flags & SCF_DO_SUBSTR) { /* Cannot merge strings after this. */ @@ -4713,164 +4713,164 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } if (flags & SCF_DO_STCLASS) - ssc_init_zero(pRExC_state, &accum); + ssc_init_zero(pRExC_state, &accum); - while (OP(scan) == code) { - SSize_t deltanext, minnext, fake; - I32 f = 0; - regnode_ssc this_class; + while (OP(scan) == code) { + SSize_t deltanext, minnext, fake; + I32 f = 0; + regnode_ssc this_class; DEBUG_PEEP("Branch", scan, depth, flags); - num++; + num++; StructCopy(&zero_scan_data, &data_fake, scan_data_t); - if (data) { - data_fake.whilem_c = data->whilem_c; - data_fake.last_closep = data->last_closep; - } - else - data_fake.last_closep = &fake; + if (data) { + data_fake.whilem_c = data->whilem_c; + data_fake.last_closep = data->last_closep; + } + else + data_fake.last_closep = &fake; - data_fake.pos_delta = delta; - next = regnext(scan); + data_fake.pos_delta = delta; + next = regnext(scan); scan = NEXTOPER(scan); /* everything */ if (code != BRANCH) /* everything but BRANCH */ - scan = NEXTOPER(scan); + scan = NEXTOPER(scan); - if (flags & SCF_DO_STCLASS) { - ssc_init(pRExC_state, &this_class); - data_fake.start_class = &this_class; - f = SCF_DO_STCLASS_AND; - } - if (flags & SCF_WHILEM_VISITED_POS) - f |= SCF_WHILEM_VISITED_POS; + if (flags & SCF_DO_STCLASS) { + ssc_init(pRExC_state, &this_class); + data_fake.start_class = &this_class; + f = SCF_DO_STCLASS_AND; + } + if (flags & SCF_WHILEM_VISITED_POS) + f |= SCF_WHILEM_VISITED_POS; - /* we suppose the run is continuous, last=next...*/ + /* we suppose the run is continuous, last=next...*/ /* recurse study_chunk() for each BRANCH in an alternation */ - minnext = study_chunk(pRExC_state, &scan, minlenp, + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, next, &data_fake, stopparen, recursed_depth, NULL, f, depth+1, mutate_ok); - if (min1 > minnext) - min1 = minnext; - if (deltanext == OPTIMIZE_INFTY) { - is_inf = is_inf_internal = 1; - max1 = OPTIMIZE_INFTY; - } else if (max1 < minnext + deltanext) - max1 = minnext + deltanext; - scan = next; - if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) - pars++; - if (data_fake.flags & SCF_SEEN_ACCEPT) { - if ( stopmin > minnext) - stopmin = min + min1; - flags &= ~SCF_DO_SUBSTR; - if (data) - data->flags |= SCF_SEEN_ACCEPT; - } - if (data) { - if (data_fake.flags & SF_HAS_EVAL) - data->flags |= SF_HAS_EVAL; - data->whilem_c = data_fake.whilem_c; - } - if (flags & SCF_DO_STCLASS) - ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class); - } - if (code == IFTHEN && num < 2) /* Empty ELSE branch */ - min1 = 0; - if (flags & SCF_DO_SUBSTR) { - data->pos_min += min1; - if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1)) - data->pos_delta = OPTIMIZE_INFTY; - else - data->pos_delta += max1 - min1; - if (max1 != min1 || is_inf) - data->cur_is_floating = 1; - } - min += min1; - if (delta == OPTIMIZE_INFTY - || OPTIMIZE_INFTY - delta - (max1 - min1) < 0) - delta = OPTIMIZE_INFTY; - else - delta += max1 - min1; - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum); - if (min1) { - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - flags &= ~SCF_DO_STCLASS; - } - } - else if (flags & SCF_DO_STCLASS_AND) { - if (min1) { - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum); - flags &= ~SCF_DO_STCLASS; - } - else { - /* Switch to OR mode: cache the old value of - * data->start_class */ - INIT_AND_WITHP; - StructCopy(data->start_class, and_withp, regnode_ssc); - flags &= ~SCF_DO_STCLASS_AND; - StructCopy(&accum, data->start_class, regnode_ssc); - flags |= SCF_DO_STCLASS_OR; - } - } + if (min1 > minnext) + min1 = minnext; + if (deltanext == OPTIMIZE_INFTY) { + is_inf = is_inf_internal = 1; + max1 = OPTIMIZE_INFTY; + } else if (max1 < minnext + deltanext) + max1 = minnext + deltanext; + scan = next; + if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) + pars++; + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > minnext) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } + if (data) { + if (data_fake.flags & SF_HAS_EVAL) + data->flags |= SF_HAS_EVAL; + data->whilem_c = data_fake.whilem_c; + } + if (flags & SCF_DO_STCLASS) + ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class); + } + if (code == IFTHEN && num < 2) /* Empty ELSE branch */ + min1 = 0; + if (flags & SCF_DO_SUBSTR) { + data->pos_min += min1; + if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1)) + data->pos_delta = OPTIMIZE_INFTY; + else + data->pos_delta += max1 - min1; + if (max1 != min1 || is_inf) + data->cur_is_floating = 1; + } + min += min1; + if (delta == OPTIMIZE_INFTY + || OPTIMIZE_INFTY - delta - (max1 - min1) < 0) + delta = OPTIMIZE_INFTY; + else + delta += max1 - min1; + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum); + if (min1) { + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + flags &= ~SCF_DO_STCLASS; + } + } + else if (flags & SCF_DO_STCLASS_AND) { + if (min1) { + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum); + flags &= ~SCF_DO_STCLASS; + } + else { + /* Switch to OR mode: cache the old value of + * data->start_class */ + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, regnode_ssc); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&accum, data->start_class, regnode_ssc); + flags |= SCF_DO_STCLASS_OR; + } + } if (PERL_ENABLE_TRIE_OPTIMISATION && OP(startbranch) == BRANCH && mutate_ok ) { - /* demq. + /* demq. Assuming this was/is a branch we are dealing with: 'scan' now points at the item that follows the branch sequence, whatever it is. We now start at the beginning of the sequence and look for subsequences of - BRANCH->EXACT=>x1 - BRANCH->EXACT=>x2 - tail + BRANCH->EXACT=>x1 + BRANCH->EXACT=>x2 + tail which would be constructed from a pattern like /A|LIST|OF|WORDS/ - If we can find such a subsequence we need to turn the first - element into a trie and then add the subsequent branch exact - strings to the trie. + If we can find such a subsequence we need to turn the first + element into a trie and then add the subsequent branch exact + strings to the trie. - We have two cases + We have two cases 1. patterns where the whole set of branches can be converted. - 2. patterns where only a subset can be converted. + 2. patterns where only a subset can be converted. - In case 1 we can replace the whole set with a single regop - for the trie. In case 2 we need to keep the start and end - branches so + In case 1 we can replace the whole set with a single regop + for the trie. In case 2 we need to keep the start and end + branches so - 'BRANCH EXACT; BRANCH EXACT; BRANCH X' - becomes BRANCH TRIE; BRANCH X; + 'BRANCH EXACT; BRANCH EXACT; BRANCH X' + becomes BRANCH TRIE; BRANCH X; - There is an additional case, that being where there is a - common prefix, which gets split out into an EXACT like node - preceding the TRIE node. + There is an additional case, that being where there is a + common prefix, which gets split out into an EXACT like node + preceding the TRIE node. - If x(1..n)==tail then we can do a simple trie, if not we make - a "jump" trie, such that when we match the appropriate word - we "jump" to the appropriate tail node. Essentially we turn - a nested if into a case structure of sorts. + If x(1..n)==tail then we can do a simple trie, if not we make + a "jump" trie, such that when we match the appropriate word + we "jump" to the appropriate tail node. Essentially we turn + a nested if into a case structure of sorts. - */ + */ - int made=0; - if (!re_trie_maxbuff) { - re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1); - if (!SvIOK(re_trie_maxbuff)) - sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT); - } + int made=0; + if (!re_trie_maxbuff) { + re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1); + if (!SvIOK(re_trie_maxbuff)) + sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT); + } if ( SvIV(re_trie_maxbuff)>=0 ) { regnode *cur; regnode *first = (regnode *)NULL; @@ -5006,8 +5006,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } Perl_re_printf( aTHX_ "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n", REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur), - PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] - ); + PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] + ); }); /* Is noper a trieable nodetype that can be merged @@ -5030,15 +5030,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * otherwise we update the end pointer. */ if ( !first ) { first = cur; - if ( noper_trietype == NOTHING ) { + if ( noper_trietype == NOTHING ) { #if !defined(DEBUGGING) && !defined(NOJUMPTRIE) - regnode * const noper_next = regnext( noper ); + regnode * const noper_next = regnext( noper ); U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0; - U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0; + U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0; #endif if ( noper_next_trietype ) { - trietype = noper_next_trietype; + trietype = noper_next_trietype; } else if (noper_next_type) { /* a NOTHING regop is 1 regop wide. * We need at least two for a trie @@ -5053,8 +5053,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, trietype = noper_trietype; prev = cur; } - if (first) - count++; + if (first) + count++; } /* end handle mergable triable node */ else { /* handle unmergable node - @@ -5157,12 +5157,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } /* TRIE_MAXBUF is non zero */ } /* do trie */ - } - else if ( code == BRANCHJ ) { /* single branch is optimized. */ - scan = NEXTOPER(NEXTOPER(scan)); - } else /* single branch is optimized. */ - scan = NEXTOPER(scan); - continue; + } + else if ( code == BRANCHJ ) { /* single branch is optimized. */ + scan = NEXTOPER(NEXTOPER(scan)); + } else /* single branch is optimized. */ + scan = NEXTOPER(scan); + continue; } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) { I32 paren = 0; regnode *start = NULL; @@ -5250,12 +5250,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS; start= NULL; /* reset start so we dont recurse later on. */ - } + } } else { - paren = stopparen; + paren = stopparen; start = scan + 2; - end = regnext(scan); - } + end = regnext(scan); + } if (start) { scan_frame *newframe; assert(end); @@ -5286,73 +5286,73 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_STUDYDATA("frame-new", data, depth, is_inf); DEBUG_PEEP("fnew", scan, depth, flags); - frame = newframe; - scan = start; - stopparen = paren; - last = end; + frame = newframe; + scan = start; + stopparen = paren; + last = end; depth = depth + 1; recursed_depth= my_recursed_depth; - continue; - } - } - else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) { - SSize_t bytelen = STR_LEN(scan), charlen; - UV uc; + continue; + } + } + else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) { + SSize_t bytelen = STR_LEN(scan), charlen; + UV uc; assert(bytelen); - if (UTF) { - const U8 * const s = (U8*)STRING(scan); - uc = utf8_to_uvchr_buf(s, s + bytelen, NULL); - charlen = utf8_length(s, s + bytelen); - } else { - uc = *((U8*)STRING(scan)); + if (UTF) { + const U8 * const s = (U8*)STRING(scan); + uc = utf8_to_uvchr_buf(s, s + bytelen, NULL); + charlen = utf8_length(s, s + bytelen); + } else { + uc = *((U8*)STRING(scan)); charlen = bytelen; - } - min += charlen; - if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */ - /* The code below prefers earlier match for fixed - offset, later match for variable offset. */ - if (data->last_end == -1) { /* Update the start info. */ - data->last_start_min = data->pos_min; + } + min += charlen; + if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */ + /* The code below prefers earlier match for fixed + offset, later match for variable offset. */ + if (data->last_end == -1) { /* Update the start info. */ + data->last_start_min = data->pos_min; data->last_start_max = is_inf ? OPTIMIZE_INFTY : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min) ? OPTIMIZE_INFTY : data->pos_min + data->pos_delta; - } - sv_catpvn(data->last_found, STRING(scan), bytelen); - if (UTF) - SvUTF8_on(data->last_found); - { - SV * const sv = data->last_found; - MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - if (mg && mg->mg_len >= 0) - mg->mg_len += charlen; - } - data->last_end = data->pos_min + charlen; - data->pos_min += charlen; /* As in the first entry. */ - data->flags &= ~SF_BEFORE_EOL; - } + } + sv_catpvn(data->last_found, STRING(scan), bytelen); + if (UTF) + SvUTF8_on(data->last_found); + { + SV * const sv = data->last_found; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + if (mg && mg->mg_len >= 0) + mg->mg_len += charlen; + } + data->last_end = data->pos_min + charlen; + data->pos_min += charlen; /* As in the first entry. */ + data->flags &= ~SF_BEFORE_EOL; + } /* ANDing the code point leaves at most it, and not in locale, and * can't match null string */ - if (flags & SCF_DO_STCLASS_AND) { + if (flags & SCF_DO_STCLASS_AND) { ssc_cp_and(data->start_class, uc); ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ssc_clear_locale(data->start_class); - } - else if (flags & SCF_DO_STCLASS_OR) { + } + else if (flags & SCF_DO_STCLASS_OR) { ssc_add_cp(data->start_class, uc); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; - } - flags &= ~SCF_DO_STCLASS; - } + } + flags &= ~SCF_DO_STCLASS; + } else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT!, so is EXACTFish */ - SSize_t bytelen = STR_LEN(scan), charlen; + SSize_t bytelen = STR_LEN(scan), charlen; const U8 * s = (U8*)STRING(scan); /* Replace a length 1 ASCII fold pair node with an ANYOFM node, @@ -5375,28 +5375,28 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, continue; } - /* Search for fixed substrings supports EXACT only. */ - if (flags & SCF_DO_SUBSTR) { - assert(data); + /* Search for fixed substrings supports EXACT only. */ + if (flags & SCF_DO_SUBSTR) { + assert(data); scan_commit(pRExC_state, data, minlenp, is_inf); - } + } charlen = UTF ? (SSize_t) utf8_length(s, s + bytelen) : bytelen; - if (unfolded_multi_char) { + if (unfolded_multi_char) { RExC_seen |= REG_UNFOLDED_MULTI_SEEN; - } - min += charlen - min_subtract; + } + min += charlen - min_subtract; assert (min >= 0); delta += min_subtract; - if (flags & SCF_DO_SUBSTR) { - data->pos_min += charlen - min_subtract; - if (data->pos_min < 0) { + if (flags & SCF_DO_SUBSTR) { + data->pos_min += charlen - min_subtract; + if (data->pos_min < 0) { data->pos_min = 0; } data->pos_delta += min_subtract; - if (min_subtract) { - data->cur_is_floating = 1; /* float */ - } - } + if (min_subtract) { + data->cur_is_floating = 1; /* float */ + } + } if (flags & SCF_DO_STCLASS) { SV* EXACTF_invlist = make_exactf_invlist(pRExC_state, scan); @@ -5419,41 +5419,41 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS; SvREFCNT_dec(EXACTF_invlist); } - } - else if (REGNODE_VARIES(OP(scan))) { - SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0; - I32 fl = 0, f = flags; - regnode * const oscan = scan; - regnode_ssc this_class; - regnode_ssc *oclass = NULL; - I32 next_is_eval = 0; - - switch (PL_regkind[OP(scan)]) { - case WHILEM: /* End of (?:...)* . */ - scan = NEXTOPER(scan); - goto finish; - case PLUS: - if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { - next = NEXTOPER(scan); - if ( ( PL_regkind[OP(next)] == EXACT + } + else if (REGNODE_VARIES(OP(scan))) { + SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0; + I32 fl = 0, f = flags; + regnode * const oscan = scan; + regnode_ssc this_class; + regnode_ssc *oclass = NULL; + I32 next_is_eval = 0; + + switch (PL_regkind[OP(scan)]) { + case WHILEM: /* End of (?:...)* . */ + scan = NEXTOPER(scan); + goto finish; + case PLUS: + if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { + next = NEXTOPER(scan); + if ( ( PL_regkind[OP(next)] == EXACT && ! isEXACTFish(OP(next))) || (flags & SCF_DO_STCLASS)) { - mincount = 1; - maxcount = REG_INFTY; - next = regnext(scan); - scan = NEXTOPER(scan); - goto do_curly; - } - } - if (flags & SCF_DO_SUBSTR) - data->pos_min++; + mincount = 1; + maxcount = REG_INFTY; + next = regnext(scan); + scan = NEXTOPER(scan); + goto do_curly; + } + } + if (flags & SCF_DO_SUBSTR) + data->pos_min++; /* This will bypass the formal 'min += minnext * mincount' * calculation in the do_curly path, so assumes min width * of the PLUS payload is exactly one. */ - min++; - /* FALLTHROUGH */ - case STAR: + min++; + /* FALLTHROUGH */ + case STAR: next = NEXTOPER(scan); /* This temporary node can now be turned into EXACTFU, and @@ -5484,121 +5484,121 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, FLAGS(next) = mask; } - if (flags & SCF_DO_STCLASS) { - mincount = 0; - maxcount = REG_INFTY; - next = regnext(scan); - scan = NEXTOPER(scan); - goto do_curly; - } - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_STCLASS) { + mincount = 0; + maxcount = REG_INFTY; + next = regnext(scan); + scan = NEXTOPER(scan); + goto do_curly; + } + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); /* Cannot extend fixed substrings */ - data->cur_is_floating = 1; /* float */ - } + data->cur_is_floating = 1; /* float */ + } is_inf = is_inf_internal = 1; scan = regnext(scan); - goto optimize_curly_tail; - case CURLY: - if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM) - && (scan->flags == stopparen)) - { - mincount = 1; - maxcount = 1; - } else { - mincount = ARG1(scan); - maxcount = ARG2(scan); - } - next = regnext(scan); - if (OP(scan) == CURLYX) { - I32 lp = (data ? *(data->last_closep) : 0); - scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX); - } - scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; - next_is_eval = (OP(scan) == EVAL); - do_curly: - if (flags & SCF_DO_SUBSTR) { + goto optimize_curly_tail; + case CURLY: + if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM) + && (scan->flags == stopparen)) + { + mincount = 1; + maxcount = 1; + } else { + mincount = ARG1(scan); + maxcount = ARG2(scan); + } + next = regnext(scan); + if (OP(scan) == CURLYX) { + I32 lp = (data ? *(data->last_closep) : 0); + scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX); + } + scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; + next_is_eval = (OP(scan) == EVAL); + do_curly: + if (flags & SCF_DO_SUBSTR) { if (mincount == 0) scan_commit(pRExC_state, data, minlenp, is_inf); /* Cannot extend fixed substrings */ - pos_before = data->pos_min; - } - if (data) { - fl = data->flags; - data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL); - if (is_inf) - data->flags |= SF_IS_INF; - } - if (flags & SCF_DO_STCLASS) { - ssc_init(pRExC_state, &this_class); - oclass = data->start_class; - data->start_class = &this_class; - f |= SCF_DO_STCLASS_AND; - f &= ~SCF_DO_STCLASS_OR; - } - /* Exclude from super-linear cache processing any {n,m} - regops for which the combination of input pos and regex - pos is not enough information to determine if a match - will be possible. - - For example, in the regex /foo(bar\s*){4,8}baz/ with the - regex pos at the \s*, the prospects for a match depend not - only on the input position but also on how many (bar\s*) - repeats into the {4,8} we are. */ + pos_before = data->pos_min; + } + if (data) { + fl = data->flags; + data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL); + if (is_inf) + data->flags |= SF_IS_INF; + } + if (flags & SCF_DO_STCLASS) { + ssc_init(pRExC_state, &this_class); + oclass = data->start_class; + data->start_class = &this_class; + f |= SCF_DO_STCLASS_AND; + f &= ~SCF_DO_STCLASS_OR; + } + /* Exclude from super-linear cache processing any {n,m} + regops for which the combination of input pos and regex + pos is not enough information to determine if a match + will be possible. + + For example, in the regex /foo(bar\s*){4,8}baz/ with the + regex pos at the \s*, the prospects for a match depend not + only on the input position but also on how many (bar\s*) + repeats into the {4,8} we are. */ if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY)) - f &= ~SCF_WHILEM_VISITED_POS; + f &= ~SCF_WHILEM_VISITED_POS; - /* This will finish on WHILEM, setting scan, or on NULL: */ + /* This will finish on WHILEM, setting scan, or on NULL: */ /* recurse study_chunk() on loop bodies */ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, last, data, stopparen, recursed_depth, NULL, (mincount == 0 ? (f & ~SCF_DO_SUBSTR) : f) , depth+1, mutate_ok); - if (flags & SCF_DO_STCLASS) - data->start_class = oclass; - if (mincount == 0 || minnext == 0) { - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - } - else if (flags & SCF_DO_STCLASS_AND) { - /* Switch to OR mode: cache the old value of - * data->start_class */ - INIT_AND_WITHP; - StructCopy(data->start_class, and_withp, regnode_ssc); - flags &= ~SCF_DO_STCLASS_AND; - StructCopy(&this_class, data->start_class, regnode_ssc); - flags |= SCF_DO_STCLASS_OR; + if (flags & SCF_DO_STCLASS) + data->start_class = oclass; + if (mincount == 0 || minnext == 0) { + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + } + else if (flags & SCF_DO_STCLASS_AND) { + /* Switch to OR mode: cache the old value of + * data->start_class */ + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, regnode_ssc); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&this_class, data->start_class, regnode_ssc); + flags |= SCF_DO_STCLASS_OR; ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; - } - } else { /* Non-zero len */ - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - } - else if (flags & SCF_DO_STCLASS_AND) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - flags &= ~SCF_DO_STCLASS; - } - if (!scan) /* It was not CURLYX, but CURLY. */ - scan = next; - if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR) - /* ? quantifier ok, except for (?{ ... }) */ - && (next_is_eval || !(mincount == 0 && maxcount == 1)) - && (minnext == 0) && (deltanext == 0) - && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) + } + } else { /* Non-zero len */ + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + } + else if (flags & SCF_DO_STCLASS_AND) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + flags &= ~SCF_DO_STCLASS; + } + if (!scan) /* It was not CURLYX, but CURLY. */ + scan = next; + if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR) + /* ? quantifier ok, except for (?{ ... }) */ + && (next_is_eval || !(mincount == 0 && maxcount == 1)) + && (minnext == 0) && (deltanext == 0) + && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) && maxcount <= REG_INFTY/3) /* Complement check for big count */ - { - _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP), + { + _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP), Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Quantifier unexpected on zero-length expression " "in regex m/%" UTF8f "/", - UTF8fARG(UTF, RExC_precomp_end - RExC_precomp, - RExC_precomp))); + UTF8fARG(UTF, RExC_precomp_end - RExC_precomp, + RExC_precomp))); } if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext ) @@ -5607,146 +5607,146 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, FAIL("Regexp out of space"); } - min += minnext * mincount; - is_inf_internal |= deltanext == OPTIMIZE_INFTY + min += minnext * mincount; + is_inf_internal |= deltanext == OPTIMIZE_INFTY || (maxcount == REG_INFTY && minnext + deltanext > 0); - is_inf |= is_inf_internal; + is_inf |= is_inf_internal; if (is_inf) { - delta = OPTIMIZE_INFTY; + delta = OPTIMIZE_INFTY; } else { - delta += (minnext + deltanext) * maxcount + delta += (minnext + deltanext) * maxcount - minnext * mincount; } - /* Try powerful optimization CURLYX => CURLYN. */ - if ( OP(oscan) == CURLYX && data - && data->flags & SF_IN_PAR - && !(data->flags & SF_HAS_EVAL) - && !deltanext && minnext == 1 + /* Try powerful optimization CURLYX => CURLYN. */ + if ( OP(oscan) == CURLYX && data + && data->flags & SF_IN_PAR + && !(data->flags & SF_HAS_EVAL) + && !deltanext && minnext == 1 && mutate_ok ) { - /* Try to optimize to CURLYN. */ - regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; - regnode * const nxt1 = nxt; + /* Try to optimize to CURLYN. */ + regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; + regnode * const nxt1 = nxt; #ifdef DEBUGGING - regnode *nxt2; + regnode *nxt2; #endif - /* Skip open. */ - nxt = regnext(nxt); - if (!REGNODE_SIMPLE(OP(nxt)) - && !(PL_regkind[OP(nxt)] == EXACT - && STR_LEN(nxt) == 1)) - goto nogo; + /* Skip open. */ + nxt = regnext(nxt); + if (!REGNODE_SIMPLE(OP(nxt)) + && !(PL_regkind[OP(nxt)] == EXACT + && STR_LEN(nxt) == 1)) + goto nogo; #ifdef DEBUGGING - nxt2 = nxt; + nxt2 = nxt; #endif - nxt = regnext(nxt); - if (OP(nxt) != CLOSE) - goto nogo; - if (RExC_open_parens) { + nxt = regnext(nxt); + if (OP(nxt) != CLOSE) + goto nogo; + if (RExC_open_parens) { /*open->CURLYM*/ RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan); /*close->while*/ RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2; - } - /* Now we know that nxt2 is the only contents: */ - oscan->flags = (U8)ARG(nxt); - OP(oscan) = CURLYN; - OP(nxt1) = NOTHING; /* was OPEN. */ + } + /* Now we know that nxt2 is the only contents: */ + oscan->flags = (U8)ARG(nxt); + OP(oscan) = CURLYN; + OP(nxt1) = NOTHING; /* was OPEN. */ #ifdef DEBUGGING - OP(nxt1 + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */ - NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */ - OP(nxt) = OPTIMIZED; /* was CLOSE. */ - OP(nxt + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */ + OP(nxt1 + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */ + NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */ + OP(nxt) = OPTIMIZED; /* was CLOSE. */ + OP(nxt + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */ #endif - } - nogo: - - /* Try optimization CURLYX => CURLYM. */ - if ( OP(oscan) == CURLYX && data - && !(data->flags & SF_HAS_PAR) - && !(data->flags & SF_HAS_EVAL) - && !deltanext /* atom is fixed width */ - && minnext != 0 /* CURLYM can't handle zero width */ + } + nogo: + + /* Try optimization CURLYX => CURLYM. */ + if ( OP(oscan) == CURLYX && data + && !(data->flags & SF_HAS_PAR) + && !(data->flags & SF_HAS_EVAL) + && !deltanext /* atom is fixed width */ + && minnext != 0 /* CURLYM can't handle zero width */ /* Nor characters whose fold at run-time may be * multi-character */ && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN) && mutate_ok - ) { - /* XXXX How to optimize if data == 0? */ - /* Optimize to a simpler form. */ - regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */ - regnode *nxt2; - - OP(oscan) = CURLYM; - while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/ - && (OP(nxt2) != WHILEM)) - nxt = nxt2; - OP(nxt2) = SUCCEED; /* Whas WHILEM */ - /* Need to optimize away parenths. */ - if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) { - /* Set the parenth number. */ - regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/ - - oscan->flags = (U8)ARG(nxt); - if (RExC_open_parens) { + ) { + /* XXXX How to optimize if data == 0? */ + /* Optimize to a simpler form. */ + regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */ + regnode *nxt2; + + OP(oscan) = CURLYM; + while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/ + && (OP(nxt2) != WHILEM)) + nxt = nxt2; + OP(nxt2) = SUCCEED; /* Whas WHILEM */ + /* Need to optimize away parenths. */ + if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) { + /* Set the parenth number. */ + regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/ + + oscan->flags = (U8)ARG(nxt); + if (RExC_open_parens) { /*open->CURLYM*/ RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan); /*close->NOTHING*/ RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2) + 1; - } - OP(nxt1) = OPTIMIZED; /* was OPEN. */ - OP(nxt) = OPTIMIZED; /* was CLOSE. */ + } + OP(nxt1) = OPTIMIZED; /* was OPEN. */ + OP(nxt) = OPTIMIZED; /* was CLOSE. */ #ifdef DEBUGGING - OP(nxt1 + 1) = OPTIMIZED; /* was count. */ - OP(nxt + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */ - NEXT_OFF(nxt + 1) = 0; /* just for consistency. */ + OP(nxt1 + 1) = OPTIMIZED; /* was count. */ + OP(nxt + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */ + NEXT_OFF(nxt + 1) = 0; /* just for consistency. */ #endif #if 0 - while ( nxt1 && (OP(nxt1) != WHILEM)) { - regnode *nnxt = regnext(nxt1); - if (nnxt == nxt) { - if (reg_off_by_arg[OP(nxt1)]) - ARG_SET(nxt1, nxt2 - nxt1); - else if (nxt2 - nxt1 < U16_MAX) - NEXT_OFF(nxt1) = nxt2 - nxt1; - else - OP(nxt) = NOTHING; /* Cannot beautify */ - } - nxt1 = nnxt; - } + while ( nxt1 && (OP(nxt1) != WHILEM)) { + regnode *nnxt = regnext(nxt1); + if (nnxt == nxt) { + if (reg_off_by_arg[OP(nxt1)]) + ARG_SET(nxt1, nxt2 - nxt1); + else if (nxt2 - nxt1 < U16_MAX) + NEXT_OFF(nxt1) = nxt2 - nxt1; + else + OP(nxt) = NOTHING; /* Cannot beautify */ + } + nxt1 = nnxt; + } #endif - /* Optimize again: */ + /* Optimize again: */ /* recurse study_chunk() on optimised CURLYX => CURLYM */ - study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, + study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, NULL, stopparen, recursed_depth, NULL, 0, depth+1, mutate_ok); - } - else - oscan->flags = 0; - } - else if ((OP(oscan) == CURLYX) - && (flags & SCF_WHILEM_VISITED_POS) - /* See the comment on a similar expression above. - However, this time it's not a subexpression - we care about, but the expression itself. */ - && (maxcount == REG_INFTY) - && data) { - /* This stays as CURLYX, we can put the count/of pair. */ - /* Find WHILEM (as in regexec.c) */ - regnode *nxt = oscan + NEXT_OFF(oscan); - - if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */ - nxt += ARG(nxt); + } + else + oscan->flags = 0; + } + else if ((OP(oscan) == CURLYX) + && (flags & SCF_WHILEM_VISITED_POS) + /* See the comment on a similar expression above. + However, this time it's not a subexpression + we care about, but the expression itself. */ + && (maxcount == REG_INFTY) + && data) { + /* This stays as CURLYX, we can put the count/of pair. */ + /* Find WHILEM (as in regexec.c) */ + regnode *nxt = oscan + NEXT_OFF(oscan); + + if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */ + nxt += ARG(nxt); nxt = PREVOPER(nxt); if (nxt->flags & 0xf) { /* we've already set whilem count on this node */ @@ -5755,68 +5755,68 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, nxt->flags = (U8)(data->whilem_c | (RExC_whilem_seen << 4)); /* On WHILEM */ } - } - if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) - pars++; - if (flags & SCF_DO_SUBSTR) { - SV *last_str = NULL; + } + if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) + pars++; + if (flags & SCF_DO_SUBSTR) { + SV *last_str = NULL; STRLEN last_chrs = 0; - int counted = mincount != 0; + int counted = mincount != 0; if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */ - SSize_t b = pos_before >= data->last_start_min - ? pos_before : data->last_start_min; - STRLEN l; - const char * const s = SvPV_const(data->last_found, l); - SSize_t old = b - data->last_start_min; + SSize_t b = pos_before >= data->last_start_min + ? pos_before : data->last_start_min; + STRLEN l; + const char * const s = SvPV_const(data->last_found, l); + SSize_t old = b - data->last_start_min; assert(old >= 0); - if (UTF) - old = utf8_hop_forward((U8*)s, old, + if (UTF) + old = utf8_hop_forward((U8*)s, old, (U8 *) SvEND(data->last_found)) - (U8*)s; - l -= old; - /* Get the added string: */ - last_str = newSVpvn_utf8(s + old, l, UTF); + l -= old; + /* Get the added string: */ + last_str = newSVpvn_utf8(s + old, l, UTF); last_chrs = UTF ? utf8_length((U8*)(s + old), (U8*)(s + old + l)) : l; - if (deltanext == 0 && pos_before == b) { - /* What was added is a constant string */ - if (mincount > 1) { + if (deltanext == 0 && pos_before == b) { + /* What was added is a constant string */ + if (mincount > 1) { - SvGROW(last_str, (mincount * l) + 1); - repeatcpy(SvPVX(last_str) + l, - SvPVX_const(last_str), l, + SvGROW(last_str, (mincount * l) + 1); + repeatcpy(SvPVX(last_str) + l, + SvPVX_const(last_str), l, mincount - 1); - SvCUR_set(last_str, SvCUR(last_str) * mincount); - /* Add additional parts. */ - SvCUR_set(data->last_found, - SvCUR(data->last_found) - l); - sv_catsv(data->last_found, last_str); - { - SV * sv = data->last_found; - MAGIC *mg = - SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - if (mg && mg->mg_len >= 0) - mg->mg_len += last_chrs * (mincount-1); - } + SvCUR_set(last_str, SvCUR(last_str) * mincount); + /* Add additional parts. */ + SvCUR_set(data->last_found, + SvCUR(data->last_found) - l); + sv_catsv(data->last_found, last_str); + { + SV * sv = data->last_found; + MAGIC *mg = + SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + if (mg && mg->mg_len >= 0) + mg->mg_len += last_chrs * (mincount-1); + } last_chrs *= mincount; - data->last_end += l * (mincount - 1); - } - } else { - /* start offset must point into the last copy */ - data->last_start_min += minnext * (mincount - 1); - data->last_start_max = + data->last_end += l * (mincount - 1); + } + } else { + /* start offset must point into the last copy */ + data->last_start_min += minnext * (mincount - 1); + data->last_start_max = is_inf ? OPTIMIZE_INFTY - : data->last_start_max + + : data->last_start_max + (maxcount - 1) * (minnext + data->pos_delta); - } - } - /* It is counted once already... */ - data->pos_min += minnext * (mincount - counted); + } + } + /* It is counted once already... */ + data->pos_min += minnext * (mincount - counted); #if 0 Perl_re_printf( aTHX_ "counted=%" UVuf " deltanext=%" UVuf " OPTIMIZE_INFTY=%" UVuf " minnext=%" UVuf @@ -5828,52 +5828,52 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", (UV)(-counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount), (UV)(OPTIMIZE_INFTY - data->pos_delta)); #endif - if (deltanext == OPTIMIZE_INFTY + if (deltanext == OPTIMIZE_INFTY || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= OPTIMIZE_INFTY - data->pos_delta) - data->pos_delta = OPTIMIZE_INFTY; - else - data->pos_delta += - counted * deltanext + - (minnext + deltanext) * maxcount - minnext * mincount; - if (mincount != maxcount) { - /* Cannot extend fixed substrings found inside - the group. */ + data->pos_delta = OPTIMIZE_INFTY; + else + data->pos_delta += - counted * deltanext + + (minnext + deltanext) * maxcount - minnext * mincount; + if (mincount != maxcount) { + /* Cannot extend fixed substrings found inside + the group. */ scan_commit(pRExC_state, data, minlenp, is_inf); - if (mincount && last_str) { - SV * const sv = data->last_found; - MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - - if (mg) - mg->mg_len = -1; - sv_setsv(sv, last_str); - data->last_end = data->pos_min; - data->last_start_min = data->pos_min - last_chrs; - data->last_start_max = is_inf - ? OPTIMIZE_INFTY - : data->pos_min + data->pos_delta - last_chrs; - } - data->cur_is_floating = 1; /* float */ - } - SvREFCNT_dec(last_str); - } - if (data && (fl & SF_HAS_EVAL)) - data->flags |= SF_HAS_EVAL; - optimize_curly_tail: - rck_elide_nothing(oscan); - continue; - - default: + if (mincount && last_str) { + SV * const sv = data->last_found; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + + if (mg) + mg->mg_len = -1; + sv_setsv(sv, last_str); + data->last_end = data->pos_min; + data->last_start_min = data->pos_min - last_chrs; + data->last_start_max = is_inf + ? OPTIMIZE_INFTY + : data->pos_min + data->pos_delta - last_chrs; + } + data->cur_is_floating = 1; /* float */ + } + SvREFCNT_dec(last_str); + } + if (data && (fl & SF_HAS_EVAL)) + data->flags |= SF_HAS_EVAL; + optimize_curly_tail: + rck_elide_nothing(oscan); + continue; + + default: Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d", OP(scan)); case REF: case CLUMP: - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_SUBSTR) { /* Cannot expect anything... */ scan_commit(pRExC_state, data, minlenp, is_inf); - data->cur_is_floating = 1; /* float */ - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) { + data->cur_is_floating = 1; /* float */ + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) { if (OP(scan) == CLUMP) { /* Actually is any start char, but very few code points * aren't start characters */ @@ -5883,12 +5883,12 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_anything(data->start_class); } } - flags &= ~SCF_DO_STCLASS; - break; - } - } - else if (OP(scan) == LNBREAK) { - if (flags & SCF_DO_STCLASS) { + flags &= ~SCF_DO_STCLASS; + break; + } + } + else if (OP(scan) == LNBREAK) { + if (flags & SCF_DO_STCLASS) { if (flags & SCF_DO_STCLASS_AND) { ssc_intersection(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); @@ -5900,16 +5900,16 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_union(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg for * 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } - flags &= ~SCF_DO_STCLASS; + flags &= ~SCF_DO_STCLASS; } - min++; + min++; if (delta != OPTIMIZE_INFTY) delta++; /* Because of the 2 char string cr-lf */ if (flags & SCF_DO_SUBSTR) { @@ -5919,17 +5919,17 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", if (data->pos_delta != OPTIMIZE_INFTY) { data->pos_delta += 1; } - data->cur_is_floating = 1; /* float */ + data->cur_is_floating = 1; /* float */ } - } - else if (REGNODE_SIMPLE(OP(scan))) { + } + else if (REGNODE_SIMPLE(OP(scan))) { - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - data->pos_min++; - } - min++; - if (flags & SCF_DO_STCLASS) { + data->pos_min++; + } + min++; + if (flags & SCF_DO_STCLASS) { bool invert = 0; SV* my_invlist = NULL; U8 namedclass; @@ -5937,21 +5937,21 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; - /* Some of the logic below assumes that switching - locale on will only add false positives. */ - switch (OP(scan)) { + /* Some of the logic below assumes that switching + locale on will only add false positives. */ + switch (OP(scan)) { - default: + default: #ifdef DEBUGGING Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); #endif - case SANY: - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - ssc_match_all_cp(data->start_class); - break; + case SANY: + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + ssc_match_all_cp(data->start_class); + break; - case REG_ANY: + case REG_ANY: { SV* REG_ANY_invlist = _new_invlist(2); REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist, @@ -5971,8 +5971,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_clear_locale(data->start_class); } SvREFCNT_dec_NN(REG_ANY_invlist); - } - break; + } + break; case ANYOFD: case ANYOFL: @@ -5982,13 +5982,13 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", case ANYOFHr: case ANYOFHs: case ANYOF: - if (flags & SCF_DO_STCLASS_AND) - ssc_and(pRExC_state, data->start_class, + if (flags & SCF_DO_STCLASS_AND) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) scan); - else - ssc_or(pRExC_state, data->start_class, + else + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) scan); - break; + break; case NANYOFM: /* NANYOFM already contains the inversion of the input ANYOF data, so, unlike things like @@ -6029,11 +6029,11 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", break; } - case NPOSIXL: + case NPOSIXL: invert = 1; /* FALLTHROUGH */ - case POSIXL: + case POSIXL: namedclass = classnum_to_namedclass(FLAGS(scan)) + invert; if (flags & SCF_DO_STCLASS_AND) { bool was_there = cBOOL( @@ -6073,16 +6073,16 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", what's matched */ invert = 1; /* FALLTHROUGH */ - case POSIXA: + case POSIXA: my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL); goto join_posix_and_ascii; - case NPOSIXD: - case NPOSIXU: + case NPOSIXD: + case NPOSIXU: invert = 1; /* FALLTHROUGH */ - case POSIXD: - case POSIXU: + case POSIXD: + case POSIXU: my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL); /* NPOSIXD matches all upper Latin1 code points unless the @@ -6106,23 +6106,23 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_union(data->start_class, my_invlist, invert); } SvREFCNT_dec(my_invlist); - } - if (flags & SCF_DO_STCLASS_OR) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - flags &= ~SCF_DO_STCLASS; - } - } - else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) { - data->flags |= (OP(scan) == MEOL - ? SF_BEFORE_MEOL - : SF_BEFORE_SEOL); + } + if (flags & SCF_DO_STCLASS_OR) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + flags &= ~SCF_DO_STCLASS; + } + } + else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) { + data->flags |= (OP(scan) == MEOL + ? SF_BEFORE_MEOL + : SF_BEFORE_SEOL); scan_commit(pRExC_state, data, minlenp, is_inf); - } - else if ( PL_regkind[OP(scan)] == BRANCHJ - /* Lookbehind, or need to calculate parens/evals/stclass: */ - && (scan->flags || data || (flags & SCF_DO_STCLASS)) - && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) + } + else if ( PL_regkind[OP(scan)] == BRANCHJ + /* Lookbehind, or need to calculate parens/evals/stclass: */ + && (scan->flags || data || (flags & SCF_DO_STCLASS)) + && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) { if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY || OP(scan) == UNLESSM ) @@ -6140,16 +6140,16 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; - } + } else data_fake.last_closep = &fake; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ ssc_init(pRExC_state, &intrnl); data_fake.start_class = &intrnl; f |= SCF_DO_STCLASS_AND; - } + } if (flags & SCF_WHILEM_VISITED_POS) f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); @@ -6166,7 +6166,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", || minnext > (I32)U8_MAX || minnext + deltanext > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %" UVuf " not implemented", + FAIL2("Lookbehind longer than %" UVuf " not implemented", (UV)U8_MAX); } @@ -6191,24 +6191,24 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", data->whilem_c = data_fake.whilem_c; } if (f & SCF_DO_STCLASS_AND) { - if (flags & SCF_DO_STCLASS_OR) { - /* OR before, AND after: ideally we would recurse with - * data_fake to get the AND applied by study of the - * remainder of the pattern, and then derecurse; - * *** HACK *** for now just treat as "no information". - * See [perl #56690]. - */ - ssc_init(pRExC_state, data->start_class); - } else { + if (flags & SCF_DO_STCLASS_OR) { + /* OR before, AND after: ideally we would recurse with + * data_fake to get the AND applied by study of the + * remainder of the pattern, and then derecurse; + * *** HACK *** for now just treat as "no information". + * See [perl #56690]. + */ + ssc_init(pRExC_state, data->start_class); + } else { /* AND before and after: combine and continue. These * assertions are zero-length, so can match an EMPTY * string */ - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; - } + } } - } + } #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY else { /* Positive Lookahead/lookbehind @@ -6246,9 +6246,9 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", data_fake.flags = 0; data_fake.substrs[0].flags = 0; data_fake.substrs[1].flags = 0; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if (is_inf) - data_fake.flags |= SF_IS_INF; + data_fake.flags |= SF_IS_INF; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ ssc_init(pRExC_state, &intrnl); @@ -6273,7 +6273,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", || *minnextp > (I32)U8_MAX || *minnextp + deltanext > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %" UVuf " not implemented", + FAIL2("Lookbehind longer than %" UVuf " not implemented", (UV)U8_MAX); } @@ -6315,65 +6315,65 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", } } } - } + } #endif - } - else if (OP(scan) == OPEN) { - if (stopparen != (I32)ARG(scan)) - pars++; - } - else if (OP(scan) == CLOSE) { - if (stopparen == (I32)ARG(scan)) { - break; - } - if ((I32)ARG(scan) == is_par) { - next = regnext(scan); - - if ( next && (OP(next) != WHILEM) && next < last) - is_par = 0; /* Disable optimization */ - } - if (data) - *(data->last_closep) = ARG(scan); - } - else if (OP(scan) == EVAL) { - if (data) - data->flags |= SF_HAS_EVAL; - } - else if ( PL_regkind[OP(scan)] == ENDLIKE ) { - if (flags & SCF_DO_SUBSTR) { + } + else if (OP(scan) == OPEN) { + if (stopparen != (I32)ARG(scan)) + pars++; + } + else if (OP(scan) == CLOSE) { + if (stopparen == (I32)ARG(scan)) { + break; + } + if ((I32)ARG(scan) == is_par) { + next = regnext(scan); + + if ( next && (OP(next) != WHILEM) && next < last) + is_par = 0; /* Disable optimization */ + } + if (data) + *(data->last_closep) = ARG(scan); + } + else if (OP(scan) == EVAL) { + if (data) + data->flags |= SF_HAS_EVAL; + } + else if ( PL_regkind[OP(scan)] == ENDLIKE ) { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - flags &= ~SCF_DO_SUBSTR; - } - if (data && OP(scan)==ACCEPT) { - data->flags |= SCF_SEEN_ACCEPT; - if (stopmin > min) - stopmin = min; - } - } - else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ - { - if (flags & SCF_DO_SUBSTR) { + flags &= ~SCF_DO_SUBSTR; + } + if (data && OP(scan)==ACCEPT) { + data->flags |= SCF_SEEN_ACCEPT; + if (stopmin > min) + stopmin = min; + } + } + else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ + { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - data->cur_is_floating = 1; /* float */ - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - ssc_anything(data->start_class); - flags &= ~SCF_DO_STCLASS; - } - else if (OP(scan) == GPOS) { + data->cur_is_floating = 1; /* float */ + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + ssc_anything(data->start_class); + flags &= ~SCF_DO_STCLASS; + } + else if (OP(scan) == GPOS) { if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) && - !(delta || is_inf || (data && data->pos_delta))) - { + !(delta || is_inf || (data && data->pos_delta))) + { if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR)) RExC_rx->intflags |= PREGf_ANCH_GPOS; - if (RExC_rx->gofs < (STRLEN)min) - RExC_rx->gofs = min; + if (RExC_rx->gofs < (STRLEN)min) + RExC_rx->gofs = min; } else { RExC_rx->intflags |= PREGf_GPOS_FLOAT; RExC_rx->gofs = 0; } - } + } #ifdef TRIE_STUDY_OPT #ifdef FULL_TRIE_STUDY else if (PL_regkind[OP(scan)] == TRIE) { @@ -6412,7 +6412,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", } else data_fake.last_closep = &fake; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if (flags & SCF_DO_STCLASS) { ssc_init(pRExC_state, &this_class); data_fake.start_class = &this_class; @@ -6449,11 +6449,11 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", pars++; if (data_fake.flags & SCF_SEEN_ACCEPT) { if ( stopmin > min + min1) - stopmin = min + min1; - flags &= ~SCF_DO_SUBSTR; - if (data) - data->flags |= SCF_SEEN_ACCEPT; - } + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -6491,7 +6491,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", else { /* Switch to OR mode: cache the old value of * data->start_class */ - INIT_AND_WITHP; + INIT_AND_WITHP; StructCopy(data->start_class, and_withp, regnode_ssc); flags &= ~SCF_DO_STCLASS_AND; StructCopy(&accum, data->start_class, regnode_ssc); @@ -6502,24 +6502,24 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", continue; } #else - else if (PL_regkind[OP(scan)] == TRIE) { - reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; - U8*bang=NULL; + else if (PL_regkind[OP(scan)] == TRIE) { + reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; + U8*bang=NULL; - min += trie->minlen; - delta += (trie->maxlen - trie->minlen); - flags &= ~SCF_DO_STCLASS; /* xxx */ + min += trie->minlen; + delta += (trie->maxlen - trie->minlen); + flags &= ~SCF_DO_STCLASS; /* xxx */ if (flags & SCF_DO_SUBSTR) { /* Cannot expect anything... */ scan_commit(pRExC_state, data, minlenp, is_inf); data->pos_min += trie->minlen; data->pos_delta += (trie->maxlen - trie->minlen); - if (trie->maxlen != trie->minlen) - data->cur_is_floating = 1; /* float */ + if (trie->maxlen != trie->minlen) + data->cur_is_floating = 1; /* float */ } if (trie->jump) /* no more substrings -- for now /grr*/ flags &= ~SCF_DO_SUBSTR; - } + } else if (OP(scan) == REGEX_SET) { Perl_croak(aTHX_ "panic: %s regnode should be resolved" " before optimization", reg_name[REGEX_SET]); @@ -6528,8 +6528,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", #endif /* old or new */ #endif /* TRIE_STUDY_OPT */ - /* Else: zero-length, ignore. */ - scan = regnext(scan); + /* Else: zero-length, ignore. */ + scan = regnext(scan); } finish: @@ -6558,19 +6558,19 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", *deltap = is_inf_internal ? OPTIMIZE_INFTY : delta; if (flags & SCF_DO_SUBSTR && is_inf) - data->pos_delta = OPTIMIZE_INFTY - data->pos_min; + data->pos_delta = OPTIMIZE_INFTY - data->pos_min; if (is_par > (I32)U8_MAX) - is_par = 0; + is_par = 0; if (is_par && pars==1 && data) { - data->flags |= SF_IN_PAR; - data->flags &= ~SF_HAS_PAR; + data->flags |= SF_IN_PAR; + data->flags &= ~SF_HAS_PAR; } else if (pars && data) { - data->flags |= SF_HAS_PAR; - data->flags &= ~SF_IN_PAR; + data->flags |= SF_HAS_PAR; + data->flags &= ~SF_IN_PAR; } if (flags & SCF_DO_STCLASS_OR) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); if (flags & SCF_TRIE_RESTUDY) data->flags |= SCF_TRIE_RESTUDY; @@ -6596,12 +6596,12 @@ S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) PERL_ARGS_ASSERT_ADD_DATA; Renewc(RExC_rxi->data, - sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1), - char, struct reg_data); + sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1), + char, struct reg_data); if(count) - Renew(RExC_rxi->data->what, count + n, U8); + Renew(RExC_rxi->data->what, count + n, U8); else - Newx(RExC_rxi->data->what, n, U8); + Newx(RExC_rxi->data->what, n, U8); RExC_rxi->data->count = count + n; Copy(s, RExC_rxi->data->what + count, n, U8); return count; @@ -6615,22 +6615,22 @@ Perl_reginitcolors(pTHX) { const char * const s = PerlEnv_getenv("PERL_RE_COLORS"); if (s) { - char *t = savepv(s); - int i = 0; - PL_colors[0] = t; - while (++i < 6) { - t = strchr(t, '\t'); - if (t) { - *t = '\0'; - PL_colors[i] = ++t; - } - else - PL_colors[i] = t = (char *)""; - } + char *t = savepv(s); + int i = 0; + PL_colors[0] = t; + while (++i < 6) { + t = strchr(t, '\t'); + if (t) { + *t = '\0'; + PL_colors[i] = ++t; + } + else + PL_colors[i] = t = (char *)""; + } } else { - int i = 0; - while (i < 6) - PL_colors[i++] = (char *)""; + int i = 0; + while (i < 6) + PL_colors[i++] = (char *)""; } PL_colorset = 1; } @@ -6667,24 +6667,24 @@ regexp_engine const * Perl_current_re_engine(pTHX) { if (IN_PERL_COMPILETIME) { - HV * const table = GvHV(PL_hintgv); - SV **ptr; + HV * const table = GvHV(PL_hintgv); + SV **ptr; - if (!table || !(PL_hints & HINT_LOCALIZE_HH)) - return &PL_core_reg_engine; - ptr = hv_fetchs(table, "regcomp", FALSE); - if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr))) - return &PL_core_reg_engine; - return INT2PTR(regexp_engine*, SvIV(*ptr)); + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) + return &PL_core_reg_engine; + ptr = hv_fetchs(table, "regcomp", FALSE); + if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr))) + return &PL_core_reg_engine; + return INT2PTR(regexp_engine*, SvIV(*ptr)); } else { - SV *ptr; - if (!PL_curcop->cop_hints_hash) - return &PL_core_reg_engine; - ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); - if ( !(ptr && SvIOK(ptr) && SvIV(ptr))) - return &PL_core_reg_engine; - return INT2PTR(regexp_engine*, SvIV(ptr)); + SV *ptr; + if (!PL_curcop->cop_hints_hash) + return &PL_core_reg_engine; + ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); + if ( !(ptr && SvIOK(ptr) && SvIV(ptr))) + return &PL_core_reg_engine; + return INT2PTR(regexp_engine*, SvIV(ptr)); } } @@ -6700,7 +6700,7 @@ Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags) /* Dispatch a request to compile a regexp to correct regexp engine. */ DEBUG_COMPILE_r({ Perl_re_printf( aTHX_ "Using engine %" UVxf "\n", - PTR2UV(eng)); + PTR2UV(eng)); }); return CALLREGCOMP_ENG(eng, pattern, flags); } @@ -6771,7 +6771,7 @@ S_alloc_code_blocks(pTHX_ int ncode) static void S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, - char **pat_p, STRLEN *plen_p, int num_code_blocks) + char **pat_p, STRLEN *plen_p, int num_code_blocks) { U8 *const src = (U8*)*pat_p; U8 *dst, *d; @@ -6930,7 +6930,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, oplist = OpSIBLING(oplist);; } - /* apply magic and QR overloading to arg */ + /* apply magic and QR overloading to arg */ SvGETMAGIC(msv); if (SvROK(msv) && SvAMAGIC(msv)) { @@ -7062,7 +7062,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, static bool S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, - char *pat, STRLEN plen) + char *pat, STRLEN plen) { int n = 0; STRLEN s; @@ -7070,21 +7070,21 @@ S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, PERL_UNUSED_CONTEXT; for (s = 0; s < plen; s++) { - if ( pRExC_state->code_blocks + if ( pRExC_state->code_blocks && n < pRExC_state->code_blocks->count - && s == pRExC_state->code_blocks->cb[n].start) - { - s = pRExC_state->code_blocks->cb[n].end; - n++; - continue; - } - /* TODO ideally should handle [..], (#..), /#.../x to reduce false - * positives here */ - if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' && - (pat[s+2] == '{' + && s == pRExC_state->code_blocks->cb[n].start) + { + s = pRExC_state->code_blocks->cb[n].end; + n++; + continue; + } + /* TODO ideally should handle [..], (#..), /#.../x to reduce false + * positives here */ + if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' && + (pat[s+2] == '{' || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{')) - ) - return 1; + ) + return 1; } return 0; } @@ -7121,39 +7121,39 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, DECLARE_AND_GET_RE_DEBUG_FLAGS; if (pRExC_state->runtime_code_qr) { - /* this is the second time we've been called; this should - * only happen if the main pattern got upgraded to utf8 - * during compilation; re-use the qr we compiled first time - * round (which should be utf8 too) - */ - qr = pRExC_state->runtime_code_qr; - pRExC_state->runtime_code_qr = NULL; - assert(RExC_utf8 && SvUTF8(qr)); + /* this is the second time we've been called; this should + * only happen if the main pattern got upgraded to utf8 + * during compilation; re-use the qr we compiled first time + * round (which should be utf8 too) + */ + qr = pRExC_state->runtime_code_qr; + pRExC_state->runtime_code_qr = NULL; + assert(RExC_utf8 && SvUTF8(qr)); } else { - int n = 0; - STRLEN s; - char *p, *newpat; - int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */ - SV *sv, *qr_ref; - dSP; - - /* determine how many extra chars we need for ' and \ escaping */ - for (s = 0; s < plen; s++) { - if (pat[s] == '\'' || pat[s] == '\\') - newlen++; - } - - Newx(newpat, newlen, char); - p = newpat; - *p++ = 'q'; *p++ = 'r'; *p++ = '\''; - - for (s = 0; s < plen; s++) { - if ( pRExC_state->code_blocks - && n < pRExC_state->code_blocks->count - && s == pRExC_state->code_blocks->cb[n].start) - { - /* blank out literal code block so that they aren't + int n = 0; + STRLEN s; + char *p, *newpat; + int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */ + SV *sv, *qr_ref; + dSP; + + /* determine how many extra chars we need for ' and \ escaping */ + for (s = 0; s < plen; s++) { + if (pat[s] == '\'' || pat[s] == '\\') + newlen++; + } + + Newx(newpat, newlen, char); + p = newpat; + *p++ = 'q'; *p++ = 'r'; *p++ = '\''; + + for (s = 0; s < plen; s++) { + if ( pRExC_state->code_blocks + && n < pRExC_state->code_blocks->count + && s == pRExC_state->code_blocks->cb[n].start) + { + /* blank out literal code block so that they aren't * recompiled: eg change from/to: * /(?{xyz})/ * /(?=====)/ @@ -7164,76 +7164,76 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, * /(?(?{xyz}))/ * /(?(?=====))/ */ - assert(pat[s] == '('); - assert(pat[s+1] == '?'); + assert(pat[s] == '('); + assert(pat[s+1] == '?'); *p++ = '('; *p++ = '?'; s += 2; - while (s < pRExC_state->code_blocks->cb[n].end) { - *p++ = '='; - s++; - } + while (s < pRExC_state->code_blocks->cb[n].end) { + *p++ = '='; + s++; + } *p++ = ')'; - n++; - continue; - } - if (pat[s] == '\'' || pat[s] == '\\') - *p++ = '\\'; - *p++ = pat[s]; - } - *p++ = '\''; - if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) { - *p++ = 'x'; + n++; + continue; + } + if (pat[s] == '\'' || pat[s] == '\\') + *p++ = '\\'; + *p++ = pat[s]; + } + *p++ = '\''; + if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) { + *p++ = 'x'; if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) { *p++ = 'x'; } } - *p++ = '\0'; - DEBUG_COMPILE_r({ + *p++ = '\0'; + DEBUG_COMPILE_r({ Perl_re_printf( aTHX_ - "%sre-parsing pattern for runtime code:%s %s\n", - PL_colors[4], PL_colors[5], newpat); - }); + "%sre-parsing pattern for runtime code:%s %s\n", + PL_colors[4], PL_colors[5], newpat); + }); - sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0); - Safefree(newpat); + sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0); + Safefree(newpat); - ENTER; - SAVETMPS; - save_re_context(); - PUSHSTACKi(PERLSI_REQUIRE); + ENTER; + SAVETMPS; + save_re_context(); + PUSHSTACKi(PERLSI_REQUIRE); /* G_RE_REPARSING causes the toker to collapse \\ into \ when * parsing qr''; normally only q'' does this. It also alters * hints handling */ - eval_sv(sv, G_SCALAR|G_RE_REPARSING); - SvREFCNT_dec_NN(sv); - SPAGAIN; - qr_ref = POPs; - PUTBACK; - { - SV * const errsv = ERRSV; - if (SvTRUE_NN(errsv)) + eval_sv(sv, G_SCALAR|G_RE_REPARSING); + SvREFCNT_dec_NN(sv); + SPAGAIN; + qr_ref = POPs; + PUTBACK; + { + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) /* use croak_sv ? */ - Perl_croak_nocontext("%" SVf, SVfARG(errsv)); - } - assert(SvROK(qr_ref)); - qr = SvRV(qr_ref); - assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp); - /* the leaving below frees the tmp qr_ref. - * Give qr a life of its own */ - SvREFCNT_inc(qr); - POPSTACK; - FREETMPS; - LEAVE; + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); + } + assert(SvROK(qr_ref)); + qr = SvRV(qr_ref); + assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp); + /* the leaving below frees the tmp qr_ref. + * Give qr a life of its own */ + SvREFCNT_inc(qr); + POPSTACK; + FREETMPS; + LEAVE; } if (!RExC_utf8 && SvUTF8(qr)) { - /* first time through; the pattern got upgraded; save the - * qr for the next time through */ - assert(!pRExC_state->runtime_code_qr); - pRExC_state->runtime_code_qr = qr; - return 0; + /* first time through; the pattern got upgraded; save the + * qr for the next time through */ + assert(!pRExC_state->runtime_code_qr); + pRExC_state->runtime_code_qr = qr; + return 0; } @@ -7242,17 +7242,17 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, /* merge the main (r1) and run-time (r2) code blocks into one */ { - RXi_GET_DECL(ReANY((REGEXP *)qr), r2); - struct reg_code_block *new_block, *dst; - RExC_state_t * const r1 = pRExC_state; /* convenient alias */ - int i1 = 0, i2 = 0; + RXi_GET_DECL(ReANY((REGEXP *)qr), r2); + struct reg_code_block *new_block, *dst; + RExC_state_t * const r1 = pRExC_state; /* convenient alias */ + int i1 = 0, i2 = 0; int r1c, r2c; - if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */ - { - SvREFCNT_dec_NN(qr); - return 1; - } + if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */ + { + SvREFCNT_dec_NN(qr); + return 1; + } if (!r1->code_blocks) r1->code_blocks = S_alloc_code_blocks(aTHX_ 0); @@ -7260,46 +7260,46 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, r1c = r1->code_blocks->count; r2c = r2->code_blocks->count; - Newx(new_block, r1c + r2c, struct reg_code_block); - - dst = new_block; - - while (i1 < r1c || i2 < r2c) { - struct reg_code_block *src; - bool is_qr = 0; - - if (i1 == r1c) { - src = &r2->code_blocks->cb[i2++]; - is_qr = 1; - } - else if (i2 == r2c) - src = &r1->code_blocks->cb[i1++]; - else if ( r1->code_blocks->cb[i1].start - < r2->code_blocks->cb[i2].start) - { - src = &r1->code_blocks->cb[i1++]; - assert(src->end < r2->code_blocks->cb[i2].start); - } - else { - assert( r1->code_blocks->cb[i1].start - > r2->code_blocks->cb[i2].start); - src = &r2->code_blocks->cb[i2++]; - is_qr = 1; - assert(src->end < r1->code_blocks->cb[i1].start); - } - - assert(pat[src->start] == '('); - assert(pat[src->end] == ')'); - dst->start = src->start; - dst->end = src->end; - dst->block = src->block; - dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr) - : src->src_regex; - dst++; - } - r1->code_blocks->count += r2c; - Safefree(r1->code_blocks->cb); - r1->code_blocks->cb = new_block; + Newx(new_block, r1c + r2c, struct reg_code_block); + + dst = new_block; + + while (i1 < r1c || i2 < r2c) { + struct reg_code_block *src; + bool is_qr = 0; + + if (i1 == r1c) { + src = &r2->code_blocks->cb[i2++]; + is_qr = 1; + } + else if (i2 == r2c) + src = &r1->code_blocks->cb[i1++]; + else if ( r1->code_blocks->cb[i1].start + < r2->code_blocks->cb[i2].start) + { + src = &r1->code_blocks->cb[i1++]; + assert(src->end < r2->code_blocks->cb[i2].start); + } + else { + assert( r1->code_blocks->cb[i1].start + > r2->code_blocks->cb[i2].start); + src = &r2->code_blocks->cb[i2++]; + is_qr = 1; + assert(src->end < r1->code_blocks->cb[i1].start); + } + + assert(pat[src->start] == '('); + assert(pat[src->end] == ')'); + dst->start = src->start; + dst->end = src->end; + dst->block = src->block; + dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr) + : src->src_regex; + dst++; + } + r1->code_blocks->count += r2c; + Safefree(r1->code_blocks->cb); + r1->code_blocks->cb = new_block; } SvREFCNT_dec_NN(qr); @@ -7507,8 +7507,8 @@ S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx) REGEXP * Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, - OP *expr, const regexp_engine* eng, REGEXP *old_re, - bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags) + OP *expr, const regexp_engine* eng, REGEXP *old_re, + bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags) { REGEXP *Rx; /* Capital 'R' means points to a REGEXP */ STRLEN plen; @@ -7549,19 +7549,19 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, pRExC_state->code_blocks = NULL; if (is_bare_re) - *is_bare_re = FALSE; + *is_bare_re = FALSE; if (expr && (expr->op_type == OP_LIST || - (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) { - /* allocate code_blocks if needed */ - OP *o; - int ncode = 0; + (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) { + /* allocate code_blocks if needed */ + OP *o; + int ncode = 0; - for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) - if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) - ncode++; /* count of DO blocks */ + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) + if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) + ncode++; /* count of DO blocks */ - if (ncode) + if (ncode) pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode); } @@ -7639,15 +7639,15 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, exp = SvPV_nomg(pat, plen); if (!eng->op_comp) { - if ((SvUTF8(pat) && IN_BYTES) - || SvGMAGICAL(pat) || SvAMAGIC(pat)) - { - /* make a temporary copy; either to convert to bytes, - * or to avoid repeating get-magic / overloaded stringify */ - pat = newSVpvn_flags(exp, plen, SVs_TEMP | - (IN_BYTES ? 0 : SvUTF8(pat))); - } - return CALLREGCOMP_ENG(eng, pat, orig_rx_flags); + if ((SvUTF8(pat) && IN_BYTES) + || SvGMAGICAL(pat) || SvAMAGIC(pat)) + { + /* make a temporary copy; either to convert to bytes, + * or to avoid repeating get-magic / overloaded stringify */ + pat = newSVpvn_flags(exp, plen, SVs_TEMP | + (IN_BYTES ? 0 : SvUTF8(pat))); + } + return CALLREGCOMP_ENG(eng, pat, orig_rx_flags); } /* ignore the utf8ness if the pattern is 0 length */ @@ -7691,11 +7691,11 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, * to utf8 */ if ((pm_flags & PMf_USE_RE_EVAL) - /* this second condition covers the non-regex literal case, - * i.e. $foo =~ '(?{})'. */ - || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL)) + /* this second condition covers the non-regex literal case, + * i.e. $foo =~ '(?{})'. */ + || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL)) ) - runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); + runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); redo_parse: /* return old regex if pattern hasn't changed */ @@ -7709,10 +7709,10 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, && !recompile && !!RX_UTF8(old_re) == !!RExC_utf8 && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) ) - && RX_PRECOMP(old_re) - && RX_PRELEN(old_re) == plen + && RX_PRECOMP(old_re) + && RX_PRELEN(old_re) == plen && memEQ(RX_PRECOMP(old_re), exp, plen) - && !runtime_code /* with runtime code, always recompile */ ) + && !runtime_code /* with runtime code, always recompile */ ) { DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); @@ -7735,9 +7735,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, && initial_charset == REGEX_DEPENDS_CHARSET) { - /* Set to use unicode semantics if the pattern is in utf8 and has the - * 'depends' charset specified, as it means unicode when utf8 */ - set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET); + /* Set to use unicode semantics if the pattern is in utf8 and has the + * 'depends' charset specified, as it means unicode when utf8 */ + set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET); RExC_uni_semantics = 1; } @@ -7745,16 +7745,16 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (runtime_code) { assert(TAINTING_get || !TAINT_get); - if (TAINT_get) - Perl_croak(aTHX_ "Eval-group in insecure regular expression"); + if (TAINT_get) + Perl_croak(aTHX_ "Eval-group in insecure regular expression"); - if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { - /* whoops, we have a non-utf8 pattern, whilst run-time code - * got compiled as utf8. Try again with a utf8 pattern */ + if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { + /* whoops, we have a non-utf8 pattern, whilst run-time code + * got compiled as utf8. Try again with a utf8 pattern */ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen, pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0); goto redo_parse; - } + } } assert(!pRExC_state->runtime_code_qr); @@ -7829,7 +7829,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK; if (pm_flags & PMf_IS_QR) { - RExC_rxi->code_blocks = pRExC_state->code_blocks; + RExC_rxi->code_blocks = pRExC_state->code_blocks; if (RExC_rxi->code_blocks) { RExC_rxi->code_blocks->refcnt++; } @@ -7871,7 +7871,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_total_parens = RExC_npar; } else if (! MUST_RESTART(flags)) { - ReREFCNT_dec(Rx); + ReREFCNT_dec(Rx); Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags); } @@ -8033,7 +8033,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; else RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN; - StructCopy(&zero_scan_data, &data, scan_data_t); + StructCopy(&zero_scan_data, &data, scan_data_t); } #else StructCopy(&zero_scan_data, &data, scan_data_t); @@ -8044,171 +8044,171 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ if (UTF) - SvUTF8_on(Rx); /* Unicode in it? */ + SvUTF8_on(Rx); /* Unicode in it? */ RExC_rxi->regstclass = NULL; if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */ - RExC_rx->intflags |= PREGf_NAUGHTY; + RExC_rx->intflags |= PREGf_NAUGHTY; scan = RExC_rxi->program + 1; /* First BRANCH. */ /* testing for BRANCH here tells us whether there is "must appear" data in the pattern. If there is then we can use it for optimisations */ if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /* Only one top-level choice. */ - SSize_t fake; - STRLEN longest_length[2]; - regnode_ssc ch_class; /* pointed to by data */ - int stclass_flag; - SSize_t last_close = 0; /* pointed to by data */ + SSize_t fake; + STRLEN longest_length[2]; + regnode_ssc ch_class; /* pointed to by data */ + int stclass_flag; + SSize_t last_close = 0; /* pointed to by data */ regnode *first= scan; regnode *first_next= regnext(first); int i; - /* - * Skip introductions and multiplicators >= 1 - * so that we can extract the 'meat' of the pattern that must - * match in the large if() sequence following. - * NOTE that EXACT is NOT covered here, as it is normally - * picked up by the optimiser separately. - * - * This is unfortunate as the optimiser isnt handling lookahead - * properly currently. - * - */ - while ((OP(first) == OPEN && (sawopen = 1)) || - /* An OR of *one* alternative - should not happen now. */ - (OP(first) == BRANCH && OP(first_next) != BRANCH) || - /* for now we can't handle lookbehind IFMATCH*/ - (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) || - (OP(first) == PLUS) || - (OP(first) == MINMOD) || - /* An {n,m} with n>0 */ - (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) || - (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END )) - { - /* - * the only op that could be a regnode is PLUS, all the rest - * will be regnode_1 or regnode_2. - * + /* + * Skip introductions and multiplicators >= 1 + * so that we can extract the 'meat' of the pattern that must + * match in the large if() sequence following. + * NOTE that EXACT is NOT covered here, as it is normally + * picked up by the optimiser separately. + * + * This is unfortunate as the optimiser isnt handling lookahead + * properly currently. + * + */ + while ((OP(first) == OPEN && (sawopen = 1)) || + /* An OR of *one* alternative - should not happen now. */ + (OP(first) == BRANCH && OP(first_next) != BRANCH) || + /* for now we can't handle lookbehind IFMATCH*/ + (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) || + (OP(first) == PLUS) || + (OP(first) == MINMOD) || + /* An {n,m} with n>0 */ + (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) || + (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END )) + { + /* + * the only op that could be a regnode is PLUS, all the rest + * will be regnode_1 or regnode_2. + * * (yves doesn't think this is true) - */ - if (OP(first) == PLUS) - sawplus = 1; + */ + if (OP(first) == PLUS) + sawplus = 1; else { if (OP(first) == MINMOD) sawminmod = 1; - first += regarglen[OP(first)]; + first += regarglen[OP(first)]; } - first = NEXTOPER(first); - first_next= regnext(first); - } + first = NEXTOPER(first); + first_next= regnext(first); + } - /* Starting-point info. */ + /* Starting-point info. */ again: DEBUG_PEEP("first:", first, 0, 0); /* Ignore EXACT as we deal with it later. */ - if (PL_regkind[OP(first)] == EXACT) { - if (! isEXACTFish(OP(first))) { - NOOP; /* Empty, get anchored substr later. */ + if (PL_regkind[OP(first)] == EXACT) { + if (! isEXACTFish(OP(first))) { + NOOP; /* Empty, get anchored substr later. */ } - else - RExC_rxi->regstclass = first; - } + else + RExC_rxi->regstclass = first; + } #ifdef TRIE_STCLASS - else if (PL_regkind[OP(first)] == TRIE && - ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0) - { + else if (PL_regkind[OP(first)] == TRIE && + ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0) + { /* this can happen only on restudy */ RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0); - } + } #endif - else if (REGNODE_SIMPLE(OP(first))) - RExC_rxi->regstclass = first; - else if (PL_regkind[OP(first)] == BOUND || - PL_regkind[OP(first)] == NBOUND) - RExC_rxi->regstclass = first; - else if (PL_regkind[OP(first)] == BOL) { + else if (REGNODE_SIMPLE(OP(first))) + RExC_rxi->regstclass = first; + else if (PL_regkind[OP(first)] == BOUND || + PL_regkind[OP(first)] == NBOUND) + RExC_rxi->regstclass = first; + else if (PL_regkind[OP(first)] == BOL) { RExC_rx->intflags |= (OP(first) == MBOL ? PREGf_ANCH_MBOL : PREGf_ANCH_SBOL); - first = NEXTOPER(first); - goto again; - } - else if (OP(first) == GPOS) { + first = NEXTOPER(first); + goto again; + } + else if (OP(first) == GPOS) { RExC_rx->intflags |= PREGf_ANCH_GPOS; - first = NEXTOPER(first); - goto again; - } - else if ((!sawopen || !RExC_sawback) && + first = NEXTOPER(first); + goto again; + } + else if ((!sawopen || !RExC_sawback) && !sawlookahead && - (OP(first) == STAR && - PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && + (OP(first) == STAR && + PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks) - { - /* turn .* into ^.* with an implied $*=1 */ - const int type = - (OP(NEXTOPER(first)) == REG_ANY) + { + /* turn .* into ^.* with an implied $*=1 */ + const int type = + (OP(NEXTOPER(first)) == REG_ANY) ? PREGf_ANCH_MBOL : PREGf_ANCH_SBOL; RExC_rx->intflags |= (type | PREGf_IMPLICIT); - first = NEXTOPER(first); - goto again; - } + first = NEXTOPER(first); + goto again; + } if (sawplus && !sawminmod && !sawlookahead && (!sawopen || !RExC_sawback) - && !pRExC_state->code_blocks) /* May examine pos and $& */ - /* x+ must match at the 1st pos of run of x's */ - RExC_rx->intflags |= PREGf_SKIP; + && !pRExC_state->code_blocks) /* May examine pos and $& */ + /* x+ must match at the 1st pos of run of x's */ + RExC_rx->intflags |= PREGf_SKIP; - /* Scan is after the zeroth branch, first is atomic matcher. */ + /* Scan is after the zeroth branch, first is atomic matcher. */ #ifdef TRIE_STUDY_OPT - DEBUG_PARSE_r( - if (!restudied) + DEBUG_PARSE_r( + if (!restudied) Perl_re_printf( aTHX_ "first at %" IVdf "\n", - (IV)(first - scan + 1)) + (IV)(first - scan + 1)) ); #else - DEBUG_PARSE_r( + DEBUG_PARSE_r( Perl_re_printf( aTHX_ "first at %" IVdf "\n", - (IV)(first - scan + 1)) + (IV)(first - scan + 1)) ); #endif - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - * [Now we resolve ties in favor of the earlier string if - * it happens that c_offset_min has been invalidated, since the - * earlier string may buy us something the later one won't.] - */ - - data.substrs[0].str = newSVpvs(""); - data.substrs[1].str = newSVpvs(""); - data.last_found = newSVpvs(""); - data.cur_is_floating = 0; /* initially any found substring is fixed */ - ENTER_with_name("study_chunk"); - SAVEFREESV(data.substrs[0].str); - SAVEFREESV(data.substrs[1].str); - SAVEFREESV(data.last_found); - first = scan; - if (!RExC_rxi->regstclass) { - ssc_init(pRExC_state, &ch_class); - data.start_class = &ch_class; - stclass_flag = SCF_DO_STCLASS_AND; - } else /* XXXX Check for BOUND? */ - stclass_flag = 0; - data.last_closep = &last_close; + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + * [Now we resolve ties in favor of the earlier string if + * it happens that c_offset_min has been invalidated, since the + * earlier string may buy us something the later one won't.] + */ + + data.substrs[0].str = newSVpvs(""); + data.substrs[1].str = newSVpvs(""); + data.last_found = newSVpvs(""); + data.cur_is_floating = 0; /* initially any found substring is fixed */ + ENTER_with_name("study_chunk"); + SAVEFREESV(data.substrs[0].str); + SAVEFREESV(data.substrs[1].str); + SAVEFREESV(data.last_found); + first = scan; + if (!RExC_rxi->regstclass) { + ssc_init(pRExC_state, &ch_class); + data.start_class = &ch_class; + stclass_flag = SCF_DO_STCLASS_AND; + } else /* XXXX Check for BOUND? */ + stclass_flag = 0; + data.last_closep = &last_close; DEBUG_RExC_seen(); /* * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/ * (NO top level branches) */ - minlen = study_chunk(pRExC_state, &first, &minlen, &fake, + minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */ &data, -1, 0, NULL, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag @@ -8219,15 +8219,15 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk")); - if ( RExC_total_parens == 1 && !data.cur_is_floating - && data.last_start_min == 0 && data.last_end > 0 - && !RExC_seen_zerolen + if ( RExC_total_parens == 1 && !data.cur_is_floating + && data.last_start_min == 0 && data.last_end > 0 + && !RExC_seen_zerolen && !(RExC_seen & REG_VERBARG_SEEN) && !(RExC_seen & REG_GPOS_SEEN) ){ - RExC_rx->extflags |= RXf_CHECK_ALL; + RExC_rx->extflags |= RXf_CHECK_ALL; } - scan_commit(pRExC_state, &data,&minlen, 0); + scan_commit(pRExC_state, &data,&minlen, 0); /* XXX this is done in reverse order because that's the way the @@ -8264,39 +8264,39 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, } } - LEAVE_with_name("study_chunk"); + LEAVE_with_name("study_chunk"); - if (RExC_rxi->regstclass - && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY)) - RExC_rxi->regstclass = NULL; + if (RExC_rxi->regstclass + && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY)) + RExC_rxi->regstclass = NULL; - if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr) + if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr) || RExC_rx->substrs->data[0].min_offset) - && stclass_flag + && stclass_flag && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && is_ssc_worth_it(pRExC_state, data.start_class)) - { - const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); + && is_ssc_worth_it(pRExC_state, data.start_class)) + { + const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); - Newx(RExC_rxi->data->data[n], 1, regnode_ssc); - StructCopy(data.start_class, - (regnode_ssc*)RExC_rxi->data->data[n], - regnode_ssc); - RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; - RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ - DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); + Newx(RExC_rxi->data->data[n], 1, regnode_ssc); + StructCopy(data.start_class, + (regnode_ssc*)RExC_rxi->data->data[n], + regnode_ssc); + RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; + RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ + DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state); Perl_re_printf( aTHX_ - "synthetic stclass \"%s\".\n", - SvPVX_const(sv));}); + "synthetic stclass \"%s\".\n", + SvPVX_const(sv));}); data.start_class = NULL; - } + } /* A temporary algorithm prefers floated substr to fixed one of * same length to dig more info. */ - i = (longest_length[0] <= longest_length[1]); + i = (longest_length[0] <= longest_length[1]); RExC_rx->substrs->check_ix = i; RExC_rx->check_end_shift = RExC_rx->substrs->data[i].end_shift; RExC_rx->check_substr = RExC_rx->substrs->data[i].substr; @@ -8306,38 +8306,38 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))) RExC_rx->intflags |= PREGf_NOSCAN; - if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) { - RExC_rx->extflags |= RXf_USE_INTUIT; - if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8)) - RExC_rx->extflags |= RXf_INTUIT_TAIL; - } + if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) { + RExC_rx->extflags |= RXf_USE_INTUIT; + if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8)) + RExC_rx->extflags |= RXf_INTUIT_TAIL; + } - /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) - if ( (STRLEN)minlen < longest_length[1] ) + /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) + if ( (STRLEN)minlen < longest_length[1] ) minlen= longest_length[1]; if ( (STRLEN)minlen < longest_length[0] ) minlen= longest_length[0]; */ } else { - /* Several toplevels. Best we can is to set minlen. */ - SSize_t fake; - regnode_ssc ch_class; - SSize_t last_close = 0; + /* Several toplevels. Best we can is to set minlen. */ + SSize_t fake; + regnode_ssc ch_class; + SSize_t last_close = 0; DEBUG_PARSE_r(Perl_re_printf( aTHX_ "\nMulti Top Level\n")); - scan = RExC_rxi->program + 1; - ssc_init(pRExC_state, &ch_class); - data.start_class = &ch_class; - data.last_closep = &last_close; + scan = RExC_rxi->program + 1; + ssc_init(pRExC_state, &ch_class); + data.start_class = &ch_class; + data.last_closep = &last_close; DEBUG_RExC_seen(); /* * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../ * (patterns WITH top level branches) */ - minlen = study_chunk(pRExC_state, + minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied ? SCF_TRIE_DOING_RESTUDY @@ -8346,7 +8346,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, CHECK_RESTUDY_GOTO_butfirst(NOOP); - RExC_rx->check_substr = NULL; + RExC_rx->check_substr = NULL; RExC_rx->check_utf8 = NULL; RExC_rx->substrs->data[0].substr = NULL; RExC_rx->substrs->data[0].utf8_substr = NULL; @@ -8354,25 +8354,25 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_rx->substrs->data[1].utf8_substr = NULL; if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && is_ssc_worth_it(pRExC_state, data.start_class)) + && is_ssc_worth_it(pRExC_state, data.start_class)) { - const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); + const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); - Newx(RExC_rxi->data->data[n], 1, regnode_ssc); - StructCopy(data.start_class, - (regnode_ssc*)RExC_rxi->data->data[n], - regnode_ssc); - RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; - RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ - DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); + Newx(RExC_rxi->data->data[n], 1, regnode_ssc); + StructCopy(data.start_class, + (regnode_ssc*)RExC_rxi->data->data[n], + regnode_ssc); + RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; + RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ + DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state); Perl_re_printf( aTHX_ - "synthetic stclass \"%s\".\n", - SvPVX_const(sv));}); + "synthetic stclass \"%s\".\n", + SvPVX_const(sv));}); data.start_class = NULL; - } + } } if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) { @@ -8403,16 +8403,16 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */ if (pRExC_state->code_blocks) - RExC_rx->extflags |= RXf_EVAL_SEEN; + RExC_rx->extflags |= RXf_EVAL_SEEN; if (RExC_seen & REG_VERBARG_SEEN) { - RExC_rx->intflags |= PREGf_VERBARG_SEEN; + RExC_rx->intflags |= PREGf_VERBARG_SEEN; RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */ } if (RExC_seen & REG_CUTGROUP_SEEN) - RExC_rx->intflags |= PREGf_CUTGROUP_SEEN; + RExC_rx->intflags |= PREGf_CUTGROUP_SEEN; if (pm_flags & PMf_USE_RE_EVAL) - RExC_rx->intflags |= PREGf_USE_RE_EVAL; + RExC_rx->intflags |= PREGf_USE_RE_EVAL; if (RExC_paren_names) RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names)); else @@ -8572,7 +8572,7 @@ Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv, - const U32 flags) + const U32 flags) { SV *ret; struct regexp *const rx = ReANY(r); @@ -8621,9 +8621,9 @@ Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key, if (flags & RXapif_ALL) { return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0); } else { - SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags); + SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags); if (sv) { - SvREFCNT_dec_NN(sv); + SvREFCNT_dec_NN(sv); return TRUE; } else { return FALSE; @@ -8642,11 +8642,11 @@ Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags) PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY; if ( rx && RXp_PAREN_NAMES(rx) ) { - (void)hv_iterinit(RXp_PAREN_NAMES(rx)); + (void)hv_iterinit(RXp_PAREN_NAMES(rx)); - return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY); + return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY); } else { - return FALSE; + return FALSE; } } @@ -8676,7 +8676,7 @@ Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags) } } if (parno || flags & RXapif_ALL) { - return newSVhek(HeKEY_hek(temphe)); + return newSVhek(HeKEY_hek(temphe)); } } } @@ -8700,7 +8700,7 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags) ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES)); av = MUTABLE_AV(SvRV(ret)); length = av_count(av); - SvREFCNT_dec_NN(ret); + SvREFCNT_dec_NN(ret); return newSViv(length); } else { Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", @@ -8748,7 +8748,7 @@ Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags) void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, - SV * const sv) + SV * const sv) { struct regexp *const rx = ReANY(r); char *s = NULL; @@ -8787,16 +8787,16 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, && rx->offs[0].start != -1) { /* $`, ${^PREMATCH} */ - i = rx->offs[0].start; - s = rx->subbeg; + i = rx->offs[0].start; + s = rx->subbeg; } else if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH) && rx->offs[0].end != -1) { /* $', ${^POSTMATCH} */ - s = rx->subbeg - rx->suboffset + rx->offs[0].end; - i = rx->sublen + rx->suboffset - rx->offs[0].end; + s = rx->subbeg - rx->suboffset + rx->offs[0].end; + i = rx->sublen + rx->suboffset - rx->offs[0].end; } else if (inRANGE(n, 0, (I32)rx->nparens) && @@ -8853,7 +8853,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, void Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, - SV const * const value) + SV const * const value) { PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE; @@ -8898,32 +8898,32 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv, case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */ case RX_BUFF_IDX_PREMATCH: /* $` */ if (rx->offs[0].start != -1) { - i = rx->offs[0].start; - if (i > 0) { - s1 = 0; - t1 = i; - goto getlen; - } - } + i = rx->offs[0].start; + if (i > 0) { + s1 = 0; + t1 = i; + goto getlen; + } + } return 0; case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */ case RX_BUFF_IDX_POSTMATCH: /* $' */ - if (rx->offs[0].end != -1) { - i = rx->sublen - rx->offs[0].end; - if (i > 0) { - s1 = rx->offs[0].end; - t1 = rx->sublen; - goto getlen; - } - } + if (rx->offs[0].end != -1) { + i = rx->sublen - rx->offs[0].end; + if (i > 0) { + s1 = rx->offs[0].end; + t1 = rx->sublen; + goto getlen; + } + } return 0; default: /* $& / ${^MATCH}, $1, $2, ... */ - if (paren <= (I32)rx->nparens && + if (paren <= (I32)rx->nparens && (s1 = rx->offs[paren].start) != -1 && (t1 = rx->offs[paren].end) != -1) - { + { i = t1 - s1; goto getlen; } else { @@ -8950,11 +8950,11 @@ SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx) { PERL_ARGS_ASSERT_REG_QR_PACKAGE; - PERL_UNUSED_ARG(rx); - if (0) - return NULL; - else - return newSVpvs("Regexp"); + PERL_UNUSED_ARG(rx); + if (0) + return NULL; + else + return newSVpvs("Regexp"); } /* Scans the name of a named buffer from the pattern. @@ -8982,22 +8982,22 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) { /* Note that the code here assumes well-formed UTF-8. Skip IDFIRST by * using do...while */ - if (UTF) - do { - RExC_parse += UTF8SKIP(RExC_parse); - } while ( RExC_parse < RExC_end + if (UTF) + do { + RExC_parse += UTF8SKIP(RExC_parse); + } while ( RExC_parse < RExC_end && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end)); - else - do { - RExC_parse++; - } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse)); + else + do { + RExC_parse++; + } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse)); } else { RExC_parse++; /* so the <- from the vFAIL is after the offending character */ vFAIL("Group name must start with a non-digit word character"); } sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start), - SVs_TEMP | (UTF ? SVf_UTF8 : 0)); + SVs_TEMP | (UTF ? SVf_UTF8 : 0)); if ( flags == REG_RSN_RETURN_NAME) return sv_name; else if (flags==REG_RSN_RETURN_DATA) { @@ -9317,7 +9317,7 @@ Perl__new_invlist(pTHX_ IV initial_size) SV* new_list; if (initial_size < 0) { - initial_size = 10; + initial_size = 10; } new_list = newSV_type(SVt_INVLIST); @@ -9363,7 +9363,7 @@ Perl__new_invlist_C_array(pTHX_ const UV* const list) SvPV_set(invlist, (char *) (list + HEADER_LENGTH)); SvLEN_set(invlist, 0); /* Means we own the contents, and the system - shouldn't touch it */ + shouldn't touch it */ *(get_invlist_offset_addr(invlist)) = offset; @@ -9403,39 +9403,39 @@ S__append_range_to_invlist(pTHX_ SV* const invlist, array = _invlist_array_init(invlist, ! offset); } else { - /* Here, the existing list is non-empty. The current max entry in the - * list is generally the first value not in the set, except when the - * set extends to the end of permissible values, in which case it is - * the first entry in that final set, and so this call is an attempt to - * append out-of-order */ - - UV final_element = len - 1; - array = invlist_array(invlist); - if ( array[final_element] > start - || ELEMENT_RANGE_MATCHES_INVLIST(final_element)) - { - Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c", - array[final_element], start, - ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f'); - } + /* Here, the existing list is non-empty. The current max entry in the + * list is generally the first value not in the set, except when the + * set extends to the end of permissible values, in which case it is + * the first entry in that final set, and so this call is an attempt to + * append out-of-order */ + + UV final_element = len - 1; + array = invlist_array(invlist); + if ( array[final_element] > start + || ELEMENT_RANGE_MATCHES_INVLIST(final_element)) + { + Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c", + array[final_element], start, + ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f'); + } /* Here, it is a legal append. If the new range begins 1 above the end * of the range below it, it is extending the range below it, so the * new first value not in the set is one greater than the newly * extended range. */ offset = *get_invlist_offset_addr(invlist); - if (array[final_element] == start) { - if (end != UV_MAX) { - array[final_element] = end + 1; - } - else { - /* But if the end is the maximum representable on the machine, + if (array[final_element] == start) { + if (end != UV_MAX) { + array[final_element] = end + 1; + } + else { + /* But if the end is the maximum representable on the machine, * assume that infinity was actually what was meant. Just let * the range that this would extend to have no end */ - invlist_set_len(invlist, len - 1, offset); - } - return; - } + invlist_set_len(invlist, len - 1, offset); + } + return; + } } /* Here the new range doesn't extend any existing set. Add it */ @@ -9445,27 +9445,27 @@ S__append_range_to_invlist(pTHX_ SV* const invlist, /* If wll overflow the existing space, extend, which may cause the array to * be moved */ if (max < len) { - invlist_extend(invlist, len); + invlist_extend(invlist, len); /* Have to set len here to avoid assert failure in invlist_array() */ invlist_set_len(invlist, len, offset); - array = invlist_array(invlist); + array = invlist_array(invlist); } else { - invlist_set_len(invlist, len, offset); + invlist_set_len(invlist, len, offset); } /* The next item on the list starts the range, the one after that is * one past the new range. */ array[len - 2] = start; if (end != UV_MAX) { - array[len - 1] = end + 1; + array[len - 1] = end + 1; } else { - /* But if the end is the maximum representable on the machine, just let - * the range have no end */ - invlist_set_len(invlist, len - 1, offset); + /* But if the end is the maximum representable on the machine, just let + * the range have no end */ + invlist_set_len(invlist, len - 1, offset); } } @@ -9489,7 +9489,7 @@ Perl__invlist_search(SV* const invlist, const UV cp) /* If list is empty, return failure. */ if (high == 0) { - return -1; + return -1; } /* (We can't get the array unless we know the list is non-empty) */ @@ -9540,20 +9540,20 @@ Perl__invlist_search(SV* const invlist, const UV cp) * The loop below converges on the i+1. Note that there may not be an * (i+1)th element in the array, and things work nonetheless */ while (low < high) { - mid = (low + high) / 2; + mid = (low + high) / 2; assert(mid <= highest_element); - if (array[mid] <= cp) { /* cp >= array[mid] */ - low = mid + 1; + if (array[mid] <= cp) { /* cp >= array[mid] */ + low = mid + 1; - /* We could do this extra test to exit the loop early. - if (cp < array[low]) { - return mid; - } - */ - } - else { /* cp < array[mid] */ - high = mid; - } + /* We could do this extra test to exit the loop early. + if (cp < array[low]) { + return mid; + } + */ + } + else { /* cp < array[mid] */ + high = mid; + } } found_entry: @@ -9686,7 +9686,7 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, SvREFCNT_dec_NN(u); } - return; + return; } /* Here both lists exist and are non-empty */ @@ -9697,8 +9697,8 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * up so are looking at b's complement. */ if (complement_b) { - /* To complement, we invert: if the first element is 0, remove it. To - * do this, we just pretend the array starts one later */ + /* To complement, we invert: if the first element is 0, remove it. To + * do this, we just pretend the array starts one later */ if (array_b[0] == 0) { array_b++; len_b--; @@ -9723,11 +9723,11 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, /* Go through each input list item by item, stopping when have exhausted * one of them */ while (i_a < len_a && i_b < len_b) { - UV cp; /* The element to potentially add to the union's array */ - bool cp_in_set; /* is it in the input list's set or not */ + UV cp; /* The element to potentially add to the union's array */ + bool cp_in_set; /* is it in the input list's set or not */ - /* We need to take one or the other of the two inputs for the union. - * Since we are merging two sorted lists, we take the smaller of the + /* We need to take one or the other of the two inputs for the union. + * Since we are merging two sorted lists, we take the smaller of the * next items. In case of a tie, we take first the one that is in its * set. If we first took the one not in its set, it would decrement * the count, possibly to 0 which would cause it to be output as ending @@ -9737,33 +9737,33 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * momentarily decremented to 0, and thus the two adjoining ranges will * be seamlessly merged. (In a tie and both are in the set or both not * in the set, it doesn't matter which we take first.) */ - if ( array_a[i_a] < array_b[i_b] - || ( array_a[i_a] == array_b[i_b] - && ELEMENT_RANGE_MATCHES_INVLIST(i_a))) - { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); - cp = array_a[i_a++]; - } - else { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); - cp = array_b[i_b++]; - } - - /* Here, have chosen which of the two inputs to look at. Only output - * if the running count changes to/from 0, which marks the - * beginning/end of a range that's in the set */ - if (cp_in_set) { - if (count == 0) { - array_u[i_u++] = cp; - } - count++; - } - else { - count--; - if (count == 0) { - array_u[i_u++] = cp; - } - } + if ( array_a[i_a] < array_b[i_b] + || ( array_a[i_a] == array_b[i_b] + && ELEMENT_RANGE_MATCHES_INVLIST(i_a))) + { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); + cp = array_a[i_a++]; + } + else { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); + cp = array_b[i_b++]; + } + + /* Here, have chosen which of the two inputs to look at. Only output + * if the running count changes to/from 0, which marks the + * beginning/end of a range that's in the set */ + if (cp_in_set) { + if (count == 0) { + array_u[i_u++] = cp; + } + count++; + } + else { + count--; + if (count == 0) { + array_u[i_u++] = cp; + } + } } @@ -9774,9 +9774,9 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * that list is in its set. (i_a and i_b each currently index the element * beyond the one we care about.) */ if ( (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a)) - || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) + || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) { - count--; + count--; } /* Above we decremented 'count' if the list that had unexamined elements in @@ -9806,11 +9806,11 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, else { IV copy_count = len_a - i_a; if (copy_count > 0) { /* The non-exhausted input is 'a' */ - Copy(array_a + i_a, array_u + i_u, copy_count, UV); + Copy(array_a + i_a, array_u + i_u, copy_count, UV); } else { /* The non-exhausted input is b */ copy_count = len_b - i_b; - Copy(array_b + i_b, array_u + i_u, copy_count, UV); + Copy(array_b + i_b, array_u + i_u, copy_count, UV); } len_u = i_u + copy_count; } @@ -9819,9 +9819,9 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * array_u, so re-find it. (Note that it is unlikely that this will * change, as we are shrinking the space, not enlarging it) */ if (len_u != _invlist_len(u)) { - invlist_set_len(u, len_u, *get_invlist_offset_addr(u)); - invlist_trim(u); - array_u = invlist_array(u); + invlist_set_len(u, len_u, *get_invlist_offset_addr(u)); + invlist_trim(u); + array_u = invlist_array(u); } if (*output == NULL) { /* Simply return the new inversion list */ @@ -9919,7 +9919,7 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, } invlist_clear(*i); - return; + return; } /* Here both lists exist and are non-empty */ @@ -9930,8 +9930,8 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * up so are looking at b's complement. */ if (complement_b) { - /* To complement, we invert: if the first element is 0, remove it. To - * do this, we just pretend the array starts one later */ + /* To complement, we invert: if the first element is 0, remove it. To + * do this, we just pretend the array starts one later */ if (array_b[0] == 0) { array_b++; len_b--; @@ -9956,12 +9956,12 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, /* Go through each list item by item, stopping when have exhausted one of * them */ while (i_a < len_a && i_b < len_b) { - UV cp; /* The element to potentially add to the intersection's - array */ - bool cp_in_set; /* Is it in the input list's set or not */ + UV cp; /* The element to potentially add to the intersection's + array */ + bool cp_in_set; /* Is it in the input list's set or not */ - /* We need to take one or the other of the two inputs for the - * intersection. Since we are merging two sorted lists, we take the + /* We need to take one or the other of the two inputs for the + * intersection. Since we are merging two sorted lists, we take the * smaller of the next items. In case of a tie, we take first the one * that is not in its set (a difference from the union algorithm). If * we first took the one in its set, it would increment the count, @@ -9971,33 +9971,33 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * opposite of this, there is no possibility that the count will be * momentarily incremented to 2. (In a tie and both are in the set or * both not in the set, it doesn't matter which we take first.) */ - if ( array_a[i_a] < array_b[i_b] - || ( array_a[i_a] == array_b[i_b] - && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a))) - { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); - cp = array_a[i_a++]; - } - else { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); - cp= array_b[i_b++]; - } - - /* Here, have chosen which of the two inputs to look at. Only output - * if the running count changes to/from 2, which marks the - * beginning/end of a range that's in the intersection */ - if (cp_in_set) { - count++; - if (count == 2) { - array_r[i_r++] = cp; - } - } - else { - if (count == 2) { - array_r[i_r++] = cp; - } - count--; - } + if ( array_a[i_a] < array_b[i_b] + || ( array_a[i_a] == array_b[i_b] + && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a))) + { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); + cp = array_a[i_a++]; + } + else { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); + cp= array_b[i_b++]; + } + + /* Here, have chosen which of the two inputs to look at. Only output + * if the running count changes to/from 2, which marks the + * beginning/end of a range that's in the intersection */ + if (cp_in_set) { + count++; + if (count == 2) { + array_r[i_r++] = cp; + } + } + else { + if (count == 2) { + array_r[i_r++] = cp; + } + count--; + } } @@ -10010,7 +10010,7 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, if ( (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a)) || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) { - count++; + count++; } /* Above we incremented 'count' if the exhausted list was in its set. This @@ -10040,11 +10040,11 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, else { /* copy the non-exhausted list, unchanged. */ IV copy_count = len_a - i_a; if (copy_count > 0) { /* a is the one with stuff left */ - Copy(array_a + i_a, array_r + i_r, copy_count, UV); + Copy(array_a + i_a, array_r + i_r, copy_count, UV); } else { /* b is the one with stuff left */ copy_count = len_b - i_b; - Copy(array_b + i_b, array_r + i_r, copy_count, UV); + Copy(array_b + i_b, array_r + i_r, copy_count, UV); } len_r = i_r + copy_count; } @@ -10053,9 +10053,9 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * array_r, so re-find it. (Note that it is unlikely that this will * change, as we are shrinking the space, not enlarging it) */ if (len_r != _invlist_len(r)) { - invlist_set_len(r, len_r, *get_invlist_offset_addr(r)); - invlist_trim(r); - array_r = invlist_array(r); + invlist_set_len(r, len_r, *get_invlist_offset_addr(r)); + invlist_trim(r); + array_r = invlist_array(r); } if (*i == NULL) { /* Simply return the calculated intersection */ @@ -10104,7 +10104,7 @@ Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end) /* This range becomes the whole inversion list if none already existed */ if (invlist == NULL) { - invlist = _new_invlist(2); + invlist = _new_invlist(2); _append_range_to_invlist(invlist, start, end); return invlist; } @@ -10383,8 +10383,8 @@ Perl__invlist_invert(pTHX_ SV* const invlist) /* The inverse of matching nothing is matching everything */ if (_invlist_len(invlist) == 0) { - _append_range_to_invlist(invlist, 0, UV_MAX); - return; + _append_range_to_invlist(invlist, 0, UV_MAX); + return; } *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist); @@ -10468,21 +10468,21 @@ S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style) invlist_iterinit(invlist); while (invlist_iternext(invlist, &start, &end)) { - if (end == UV_MAX) { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c", + if (end == UV_MAX) { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c", start, intra_range_delimiter, inter_range_delimiter); - } - else if (end != start) { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c", - start, + } + else if (end != start) { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c", + start, intra_range_delimiter, end, inter_range_delimiter); - } - else { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c", + } + else { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c", start, inter_range_delimiter); - } + } } if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */ @@ -10525,20 +10525,20 @@ Perl__invlist_dump(pTHX_ PerlIO *file, I32 level, invlist_iterinit(invlist); while (invlist_iternext(invlist, &start, &end)) { - if (end == UV_MAX) { - Perl_dump_indent(aTHX_ level, file, + if (end == UV_MAX) { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n", indent, (UV)count, start); - } - else if (end != start) { - Perl_dump_indent(aTHX_ level, file, + } + else if (end != start) { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n", - indent, (UV)count, start, end); - } - else { - Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n", + indent, (UV)count, start, end); + } + else { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n", indent, (UV)count, start); - } + } count += 2; } } @@ -10944,7 +10944,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) : WASTED_G; if (! (wastedflags & wflagbit) ) { wastedflags |= wflagbit; - /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ vWARN5( RExC_parse + 1, "Useless (%s%c) - %suse /%c modifier", @@ -10964,7 +10964,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) if (ckWARN(WARN_REGEXP)) { if (! (wastedflags & WASTED_C) ) { wastedflags |= WASTED_GC; - /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ vWARN3( RExC_parse + 1, "Useless (%sc) - %suse /gc modifier", @@ -11025,7 +11025,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) default: fail_modifiers: RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); - /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized", UTF8fARG(UTF, RExC_parse-seqstart, seqstart)); NOT_REACHED; /*NOTREACHED*/ @@ -11181,7 +11181,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) && *(RExC_parse - 1) != '('; if (RExC_parse >= RExC_end) { - vFAIL("Unmatched ("); + vFAIL("Unmatched ("); } if (paren == 'r') { /* Atomic script run */ @@ -11189,10 +11189,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) goto parse_rest; } else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */ - char *start_verb = RExC_parse + 1; - STRLEN verb_len; - char *start_arg = NULL; - unsigned char op = 0; + char *start_verb = RExC_parse + 1; + STRLEN verb_len; + char *start_arg = NULL; + unsigned char op = 0; int arg_required = 0; int internal_argval = -1; /* if >-1 we are not allowed an argument*/ bool has_upper = FALSE; @@ -11209,11 +11209,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("In '(*...)', the '(' and '*' must be adjacent"); } } - while (RExC_parse < RExC_end && *RExC_parse != ')' ) { - if ( *RExC_parse == ':' ) { - start_arg = RExC_parse + 1; - break; - } + while (RExC_parse < RExC_end && *RExC_parse != ')' ) { + if ( *RExC_parse == ':' ) { + start_arg = RExC_parse + 1; + break; + } else if (! UTF) { if (isUPPER(*RExC_parse)) { has_upper = TRUE; @@ -11223,18 +11223,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) else { RExC_parse += UTF8SKIP(RExC_parse); } - } - verb_len = RExC_parse - start_verb; - if ( start_arg ) { + } + verb_len = RExC_parse - start_verb; + if ( start_arg ) { if (RExC_parse >= RExC_end) { goto unterminated_verb_pattern; } - RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; - while ( RExC_parse < RExC_end && *RExC_parse != ')' ) { + RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; + while ( RExC_parse < RExC_end && *RExC_parse != ')' ) { RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; } - if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { + if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { unterminated_verb_pattern: if (has_upper) { vFAIL("Unterminated verb pattern argument"); @@ -11243,8 +11243,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Unterminated '(*...' argument"); } } - } else { - if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { + } else { + if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { if (has_upper) { vFAIL("Unterminated verb pattern"); } @@ -11252,29 +11252,29 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Unterminated '(*...' construct"); } } - } + } /* Here, we know that RExC_parse < RExC_end */ - switch ( *start_verb ) { + switch ( *start_verb ) { case 'A': /* (*ACCEPT) */ if ( memEQs(start_verb, verb_len,"ACCEPT") ) { - op = ACCEPT; - internal_argval = RExC_nestroot; - } - break; + op = ACCEPT; + internal_argval = RExC_nestroot; + } + break; case 'C': /* (*COMMIT) */ if ( memEQs(start_verb, verb_len,"COMMIT") ) op = COMMIT; break; case 'F': /* (*FAIL) */ if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) { - op = OPFAIL; - } - break; + op = OPFAIL; + } + break; case ':': /* (*:NAME) */ - case 'M': /* (*MARK:NAME) */ - if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) { + case 'M': /* (*MARK:NAME) */ + if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) { op = MARKPOINT; arg_required = 1; } @@ -11431,7 +11431,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret=reganode(pRExC_state, OPFAIL, 0); nextchar(pRExC_state); return ret; - } + } RExC_parse = start_arg; goto parse_rest; @@ -11440,11 +11440,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL2utf8f( "'(*%" UTF8f "' requires a terminating ':'", UTF8fARG(UTF, verb_len, start_verb)); - NOT_REACHED; /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ - } /* End of switch */ - if ( ! op ) { - RExC_parse += UTF + } /* End of switch */ + if ( ! op ) { + RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; if (has_upper || verb_len == 0) { @@ -11457,7 +11457,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) "Unknown '(*...)' construct '%" UTF8f "'", UTF8fARG(UTF, verb_len, start_verb)); } - } + } if ( RExC_parse == start_arg ) { start_arg = NULL; } @@ -11483,12 +11483,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } if ( internal_argval != -1 ) ARG2L_SET(REGNODE_p(ret), internal_argval); - nextchar(pRExC_state); - return ret; + nextchar(pRExC_state); + return ret; } else if (*RExC_parse == '?') { /* (?...) */ - bool is_logical = 0; - const char * const seqstart = RExC_parse; + bool is_logical = 0; + const char * const seqstart = RExC_parse; const char * endptr; const char non_existent_group_msg[] = "Reference to nonexistent group"; @@ -11499,24 +11499,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("In '(?...)', the '(' and '?' must be adjacent"); } - RExC_parse++; /* past the '?' */ + RExC_parse++; /* past the '?' */ paren = *RExC_parse; /* might be a trailing NUL, if not well-formed */ RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; if (RExC_parse > RExC_end) { paren = '\0'; } - ret = 0; /* For look-ahead/behind. */ - switch (paren) { + ret = 0; /* For look-ahead/behind. */ + switch (paren) { - case 'P': /* (?P...) variants for those used to PCRE/Python */ - paren = *RExC_parse; - if ( paren == '<') { /* (?P<...>) named capture */ + case 'P': /* (?P...) variants for those used to PCRE/Python */ + paren = *RExC_parse; + if ( paren == '<') { /* (?P<...>) named capture */ RExC_parse++; if (RExC_parse >= RExC_end) { vFAIL("Sequence (?P<... not terminated"); } - goto named_capture; + goto named_capture; } else if (paren == '>') { /* (?P>name) named recursion */ RExC_parse++; @@ -11532,33 +11532,33 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ - vFAIL3("Sequence (%.*s...) not recognized", + vFAIL3("Sequence (%.*s...) not recognized", (int) (RExC_parse - seqstart), seqstart); - NOT_REACHED; /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ case '<': /* (?<...) */ /* If you want to support (?<*...), first reconcile with GH #17363 */ - if (*RExC_parse == '!') - paren = ','; - else if (*RExC_parse != '=') + if (*RExC_parse == '!') + paren = ','; + else if (*RExC_parse != '=') named_capture: - { /* (?<...>) */ - char *name_start; - SV *svname; - paren= '>'; + { /* (?<...>) */ + char *name_start; + SV *svname; + paren= '>'; /* FALLTHROUGH */ case '\'': /* (?'...') */ name_start = RExC_parse; svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME); - if ( RExC_parse == name_start + if ( RExC_parse == name_start || RExC_parse >= RExC_end || *RExC_parse != paren) { - vFAIL2("Sequence (?%c... not terminated", - paren=='>' ? '<' : (char) paren); + vFAIL2("Sequence (?%c... not terminated", + paren=='>' ? '<' : (char) paren); } - { - HE *he_str; - SV *sv_dat = NULL; + { + HE *he_str; + SV *sv_dat = NULL; if (!svname) /* shouldn't happen */ Perl_croak(aTHX_ "panic: reg_scan_name returned NULL"); @@ -11617,56 +11617,56 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) /*sv_dump(sv_dat);*/ } nextchar(pRExC_state); - paren = 1; - goto capturing_parens; - } + paren = 1; + goto capturing_parens; + } RExC_seen |= REG_LOOKBEHIND_SEEN; - RExC_in_lookaround++; - RExC_parse++; + RExC_in_lookaround++; + RExC_parse++; if (RExC_parse >= RExC_end) { vFAIL("Sequence (?... not terminated"); } RExC_seen_zerolen++; break; - case '=': /* (?=...) */ - RExC_seen_zerolen++; + case '=': /* (?=...) */ + RExC_seen_zerolen++; RExC_in_lookaround++; break; - case '!': /* (?!...) */ - RExC_seen_zerolen++; - /* check if we're really just a "FAIL" assertion */ + case '!': /* (?!...) */ + RExC_seen_zerolen++; + /* check if we're really just a "FAIL" assertion */ skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); - if (*RExC_parse == ')') { + if (*RExC_parse == ')') { ret=reganode(pRExC_state, OPFAIL, 0); - nextchar(pRExC_state); - return ret; - } + nextchar(pRExC_state); + return ret; + } RExC_in_lookaround++; - break; - case '|': /* (?|...) */ - /* branch reset, behave like a (?:...) except that - buffers in alternations share the same numbers */ - paren = ':'; - after_freeze = freeze_paren = RExC_npar; + break; + case '|': /* (?|...) */ + /* branch reset, behave like a (?:...) except that + buffers in alternations share the same numbers */ + paren = ':'; + after_freeze = freeze_paren = RExC_npar; /* XXX This construct currently requires an extra pass. * Investigation would be required to see if that could be * changed */ REQUIRE_PARENS_PASS; - break; - case ':': /* (?:...) */ - case '>': /* (?>...) */ - break; - case '$': /* (?$...) */ - case '@': /* (?@...) */ - vFAIL2("Sequence (?%c...) not implemented", (int)paren); - break; - case '0' : /* (?0) */ - case 'R' : /* (?R) */ + break; + case ':': /* (?:...) */ + case '>': /* (?>...) */ + break; + case '$': /* (?$...) */ + case '@': /* (?@...) */ + vFAIL2("Sequence (?%c...) not implemented", (int)paren); + break; + case '0' : /* (?0) */ + case 'R' : /* (?R) */ if (RExC_parse == RExC_end || *RExC_parse != ')') - FAIL("Sequence (?R) not terminated"); + FAIL("Sequence (?R) not terminated"); num = 0; RExC_seen |= REG_RECURSE_SEEN; @@ -11674,9 +11674,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) * It probably could be changed */ REQUIRE_PARENS_PASS; - *flagp |= POSTPONED; + *flagp |= POSTPONED; goto gen_recurse_regop; - /*notreached*/ + /*notreached*/ /* named and numeric backreferences */ case '&': /* (?&NAME) */ parse_start = RExC_parse - 1; @@ -11704,8 +11704,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '1': case '2': case '3': case '4': /* (?1) */ - case '5': case '6': case '7': case '8': case '9': - RExC_parse = (char *) seqstart + 1; /* Point to the digit */ + case '5': case '6': case '7': case '8': case '9': + RExC_parse = (char *) seqstart + 1; /* Point to the digit */ parse_recursion: { bool is_neg = FALSE; @@ -11735,8 +11735,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) num = -num; } } - if (*RExC_parse!=')') - vFAIL("Expecting close bracket"); + if (*RExC_parse!=')') + vFAIL("Expecting close bracket"); gen_recurse_regop: if (paren == '-' || paren == '+') { @@ -11811,7 +11811,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */ - Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */ + Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */ *flagp |= POSTPONED; assert(*RExC_parse == ')'); @@ -11820,43 +11820,43 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) /* NOTREACHED */ - case '?': /* (??...) */ - is_logical = 1; - if (*RExC_parse != '{') { + case '?': /* (??...) */ + is_logical = 1; + if (*RExC_parse != '{') { RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f( "Sequence (%" UTF8f "...) not recognized", UTF8fARG(UTF, RExC_parse-seqstart, seqstart)); - NOT_REACHED; /*NOTREACHED*/ - } - *flagp |= POSTPONED; - paren = '{'; + NOT_REACHED; /*NOTREACHED*/ + } + *flagp |= POSTPONED; + paren = '{'; RExC_parse++; - /* FALLTHROUGH */ - case '{': /* (?{...}) */ - { - U32 n = 0; - struct reg_code_block *cb; + /* FALLTHROUGH */ + case '{': /* (?{...}) */ + { + U32 n = 0; + struct reg_code_block *cb; OP * o; - RExC_seen_zerolen++; + RExC_seen_zerolen++; - if ( !pRExC_state->code_blocks - || pRExC_state->code_index + if ( !pRExC_state->code_blocks + || pRExC_state->code_index >= pRExC_state->code_blocks->count - || pRExC_state->code_blocks->cb[pRExC_state->code_index].start - != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0)) - - RExC_start) - ) { - if (RExC_pm_flags & PMf_USE_RE_EVAL) - FAIL("panic: Sequence (?{...}): no code block found\n"); - FAIL("Eval-group not allowed at runtime, use re 'eval'"); - } - /* this is a pre-compiled code block (?{...}) */ - cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index]; - RExC_parse = RExC_start + cb->end; - o = cb->block; + || pRExC_state->code_blocks->cb[pRExC_state->code_index].start + != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0)) + - RExC_start) + ) { + if (RExC_pm_flags & PMf_USE_RE_EVAL) + FAIL("panic: Sequence (?{...}): no code block found\n"); + FAIL("Eval-group not allowed at runtime, use re 'eval'"); + } + /* this is a pre-compiled code block (?{...}) */ + cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index]; + RExC_parse = RExC_start + cb->end; + o = cb->block; if (cb->src_regex) { n = add_data(pRExC_state, STR_WITH_LEN("rl")); RExC_rxi->data->data[n] = @@ -11868,12 +11868,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1); RExC_rxi->data->data[n] = (void*)o; } - pRExC_state->code_index++; - nextchar(pRExC_state); + pRExC_state->code_index++; + nextchar(pRExC_state); - if (is_logical) { + if (is_logical) { regnode_offset eval; - ret = reg_node(pRExC_state, LOGICAL); + ret = reg_node(pRExC_state, LOGICAL); eval = reg2Lanode(pRExC_state, EVAL, n, @@ -11887,24 +11887,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) REQUIRE_BRANCHJ(flagp, 0); } /* deal with the length of this later - MJD */ - return ret; - } - ret = reg2Lanode(pRExC_state, EVAL, n, 0); - Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); - Set_Node_Offset(REGNODE_p(ret), parse_start); - return ret; - } - case '(': /* (?(?{...})...) and (?(?=...)...) */ - { - int is_define= 0; + return ret; + } + ret = reg2Lanode(pRExC_state, EVAL, n, 0); + Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); + Set_Node_Offset(REGNODE_p(ret), parse_start); + return ret; + } + case '(': /* (?(?{...})...) and (?(?=...)...) */ + { + int is_define= 0; const int DEFINE_len = sizeof("DEFINE") - 1; - if ( RExC_parse < RExC_end - 1 + if ( RExC_parse < RExC_end - 1 && ( ( RExC_parse[0] == '?' /* (?(?...)) */ && ( RExC_parse[1] == '=' || RExC_parse[1] == '!' || RExC_parse[1] == '<' || RExC_parse[1] == '{')) - || ( RExC_parse[0] == '*' /* (?(*...)) */ + || ( RExC_parse[0] == '*' /* (?(*...)) */ && ( memBEGINs(RExC_parse + 1, (Size_t) (RExC_end - (RExC_parse + 1)), "pla:") @@ -11943,14 +11943,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } goto insert_if; } - else if ( RExC_parse[0] == '<' /* (?()...) */ - || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ - { - char ch = RExC_parse[0] == '<' ? '>' : '\''; - char *name_start= RExC_parse++; - U32 num = 0; - SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); - if ( RExC_parse == name_start + else if ( RExC_parse[0] == '<' /* (?()...) */ + || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ + { + char ch = RExC_parse[0] == '<' ? '>' : '\''; + char *name_start= RExC_parse++; + U32 num = 0; + SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); + if ( RExC_parse == name_start || RExC_parse >= RExC_end || *RExC_parse != ch) { @@ -11965,23 +11965,23 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } ret = reganode(pRExC_state, GROUPPN, num); goto insert_if_check_paren; - } - else if (memBEGINs(RExC_parse, + } + else if (memBEGINs(RExC_parse, (STRLEN) (RExC_end - RExC_parse), "DEFINE")) { - ret = reganode(pRExC_state, DEFINEP, 0); - RExC_parse += DEFINE_len; - is_define = 1; - goto insert_if_check_paren; - } - else if (RExC_parse[0] == 'R') { - RExC_parse++; + ret = reganode(pRExC_state, DEFINEP, 0); + RExC_parse += DEFINE_len; + is_define = 1; + goto insert_if_check_paren; + } + else if (RExC_parse[0] == 'R') { + RExC_parse++; /* parno == 0 => /(?(R)YES|NO)/ "in any form of recursion OR eval" * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)" * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)" */ - parno = 0; + parno = 0; if (RExC_parse[0] == '0') { parno = 1; RExC_parse++; @@ -11996,20 +11996,20 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) RExC_parse = (char*)endptr; } /* else "Switch condition not recognized" below */ - } else if (RExC_parse[0] == '&') { - SV *sv_dat; - RExC_parse++; - sv_dat = reg_scan_name(pRExC_state, + } else if (RExC_parse[0] == '&') { + SV *sv_dat; + RExC_parse++; + sv_dat = reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); if (sv_dat) parno = 1 + *((I32 *)SvPVX(sv_dat)); - } - ret = reganode(pRExC_state, INSUBP, parno); - goto insert_if_check_paren; - } + } + ret = reganode(pRExC_state, INSUBP, parno); + goto insert_if_check_paren; + } else if (inRANGE(RExC_parse[0], '1', '9')) { /* (?(1)...) */ - char c; + char c; UV uv; endptr = RExC_end; if (grok_atoUV(RExC_parse, &uv, &endptr) @@ -12024,21 +12024,21 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret = reganode(pRExC_state, GROUPP, parno); insert_if_check_paren: - if (UCHARAT(RExC_parse) != ')') { + if (UCHARAT(RExC_parse) != ')') { RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; - vFAIL("Switch condition not recognized"); - } - nextchar(pRExC_state); - insert_if: + vFAIL("Switch condition not recognized"); + } + nextchar(pRExC_state); + insert_if: if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0))) { REQUIRE_BRANCHJ(flagp, 0); } br = regbranch(pRExC_state, &flags, 1, depth+1); - if (br == 0) { + if (br == 0) { RETURN_FAIL_ON_RESTART(flags,flagp); FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); @@ -12048,13 +12048,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) { REQUIRE_BRANCHJ(flagp, 0); } - c = UCHARAT(RExC_parse); + c = UCHARAT(RExC_parse); nextchar(pRExC_state); - if (flags&HASWIDTH) - *flagp |= HASWIDTH; - if (c == '|') { - if (is_define) - vFAIL("(?(DEFINE)....) does not allow branches"); + if (flags&HASWIDTH) + *flagp |= HASWIDTH; + if (c == '|') { + if (is_define) + vFAIL("(?(DEFINE)....) does not allow branches"); /* Fake one for optimizer. */ lastbr = reganode(pRExC_state, IFTHEN, 0); @@ -12068,23 +12068,23 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) REQUIRE_BRANCHJ(flagp, 0); } if (flags&HASWIDTH) - *flagp |= HASWIDTH; + *flagp |= HASWIDTH; c = UCHARAT(RExC_parse); nextchar(pRExC_state); - } - else - lastbr = 0; + } + else + lastbr = 0; if (c != ')') { if (RExC_parse >= RExC_end) vFAIL("Switch (?(condition)... not terminated"); else vFAIL("Switch (?(condition)... contains too many branches"); } - ender = reg_node(pRExC_state, TAIL); + ender = reg_node(pRExC_state, TAIL); if (! REGTAIL(pRExC_state, br, ender)) { REQUIRE_BRANCHJ(flagp, 0); } - if (lastbr) { + if (lastbr) { if (! REGTAIL(pRExC_state, lastbr, ender)) { REQUIRE_BRANCHJ(flagp, 0); } @@ -12096,8 +12096,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) { REQUIRE_BRANCHJ(flagp, 0); } - } - else + } + else if (! REGTAIL(pRExC_state, ret, ender)) { REQUIRE_BRANCHJ(flagp, 0); } @@ -12106,18 +12106,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) For large programs it seems to be required but I can't figure out why. -- dmq*/ #endif - return ret; - } + return ret; + } RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; vFAIL("Unknown switch condition (?(...))"); - } - case '[': /* (?[ ... ]) */ + } + case '[': /* (?[ ... ]) */ return handle_regex_sets(pRExC_state, NULL, flagp, depth+1, oregcomp_parse); case 0: /* A NUL */ - RExC_parse--; /* for vFAIL to print correctly */ + RExC_parse--; /* for vFAIL to print correctly */ vFAIL("Sequence (? incomplete"); break; @@ -12127,11 +12127,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '*': /* If you want to support (?*...), first reconcile with GH #17363 */ - /* FALLTHROUGH */ - default: /* e.g., (?i) */ - RExC_parse = (char *) seqstart + 1; + /* FALLTHROUGH */ + default: /* e.g., (?i) */ + RExC_parse = (char *) seqstart + 1; parse_flags: - parse_lparen_question_flags(pRExC_state); + parse_lparen_question_flags(pRExC_state); if (UCHARAT(RExC_parse) != ':') { if (RExC_parse < RExC_end) nextchar(pRExC_state); @@ -12143,11 +12143,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret = 0; goto parse_rest; } /* end switch */ - } + } else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) { /* (...) */ - capturing_parens: - parno = RExC_npar; - RExC_npar++; + capturing_parens: + parno = RExC_npar; + RExC_npar++; if (! ALL_PARENS_COUNTED) { /* If we are in our first pass through (and maybe only pass), * we need to allocate memory for the capturing parentheses @@ -12192,7 +12192,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } } - ret = reganode(pRExC_state, OPEN, parno); + ret = reganode(pRExC_state, OPEN, parno); if (!RExC_nestroot) RExC_nestroot = parno; if (RExC_open_parens && !RExC_open_parens[parno]) @@ -12206,15 +12206,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */ - is_open = 1; - } else { + is_open = 1; + } else { /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */ paren = ':'; - ret = 0; + ret = 0; } } else /* ! paren */ - ret = 0; + ret = 0; parse_rest: /* Pick up the branches, linking them together. */ @@ -12228,18 +12228,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); } if (*RExC_parse == '|') { - if (RExC_use_BRANCHJ) { - reginsert(pRExC_state, BRANCHJ, br, depth+1); - } - else { /* MJD */ - reginsert(pRExC_state, BRANCH, br, depth+1); + if (RExC_use_BRANCHJ) { + reginsert(pRExC_state, BRANCHJ, br, depth+1); + } + else { /* MJD */ + reginsert(pRExC_state, BRANCH, br, depth+1); Set_Node_Length(REGNODE_p(br), paren != 0); Set_Node_Offset_To_R(br, parse_start-RExC_start); } - have_branch = 1; + have_branch = 1; } else if (paren == ':') { - *flagp |= flags&SIMPLE; + *flagp |= flags&SIMPLE; } if (is_open) { /* Starts with OPEN. */ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */ @@ -12247,82 +12247,82 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } } else if (paren != '?') /* Not Conditional */ - ret = br; + ret = br; *flagp |= flags & (HASWIDTH | POSTPONED); lastbr = br; while (*RExC_parse == '|') { - if (RExC_use_BRANCHJ) { + if (RExC_use_BRANCHJ) { bool shut_gcc_up; - ender = reganode(pRExC_state, LONGJMP, 0); + ender = reganode(pRExC_state, LONGJMP, 0); /* Append to the previous. */ shut_gcc_up = REGTAIL(pRExC_state, REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))), ender); PERL_UNUSED_VAR(shut_gcc_up); - } - nextchar(pRExC_state); - if (freeze_paren) { - if (RExC_npar > after_freeze) - after_freeze = RExC_npar; + } + nextchar(pRExC_state); + if (freeze_paren) { + if (RExC_npar > after_freeze) + after_freeze = RExC_npar; RExC_npar = freeze_paren; } br = regbranch(pRExC_state, &flags, 0, depth+1); - if (br == 0) { + if (br == 0) { RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); } if (! REGTAIL(pRExC_state, lastbr, br)) { /* BRANCH -> BRANCH. */ REQUIRE_BRANCHJ(flagp, 0); } - lastbr = br; - *flagp |= flags & (HASWIDTH | POSTPONED); + lastbr = br; + *flagp |= flags & (HASWIDTH | POSTPONED); } if (have_branch || paren != ':') { regnode * br; - /* Make a closing node, and hook it on the end. */ - switch (paren) { - case ':': - ender = reg_node(pRExC_state, TAIL); - break; - case 1: case 2: - ender = reganode(pRExC_state, CLOSE, parno); + /* Make a closing node, and hook it on the end. */ + switch (paren) { + case ':': + ender = reg_node(pRExC_state, TAIL); + break; + case 1: case 2: + ender = reganode(pRExC_state, CLOSE, parno); if ( RExC_close_parens ) { DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_ "%*s%*s Setting close paren #%" IVdf " to %zu\n", 22, "| |", (int)(depth * 2 + 1), "", (IV)parno, ender)); RExC_close_parens[parno]= ender; - if (RExC_nestroot == parno) - RExC_nestroot = 0; - } + if (RExC_nestroot == parno) + RExC_nestroot = 0; + } Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */ Set_Node_Length(REGNODE_p(ender), 1); /* MJD */ - break; - case 's': - ender = reg_node(pRExC_state, SRCLOSE); + break; + case 's': + ender = reg_node(pRExC_state, SRCLOSE); RExC_in_script_run = 0; - break; - case '<': + break; + case '<': case 'a': case 'A': case 'b': case 'B': - case ',': - case '=': - case '!': - *flagp &= ~HASWIDTH; - /* FALLTHROUGH */ + case ',': + case '=': + case '!': + *flagp &= ~HASWIDTH; + /* FALLTHROUGH */ case 't': /* aTomic */ - case '>': - ender = reg_node(pRExC_state, SUCCEED); - break; - case 0: - ender = reg_node(pRExC_state, END); + case '>': + ender = reg_node(pRExC_state, SUCCEED); + break; + case 0: + ender = reg_node(pRExC_state, END); assert(!RExC_end_op); /* there can only be one! */ RExC_end_op = REGNODE_p(ender); if (RExC_close_parens) { @@ -12333,8 +12333,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) RExC_close_parens[0]= ender; } - break; - } + break; + } DEBUG_PARSE_r({ DEBUG_PARSE_MSG("lsbr"); regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state); @@ -12351,15 +12351,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) REQUIRE_BRANCHJ(flagp, 0); } - if (have_branch) { + if (have_branch) { char is_nothing= 1; - if (depth==1) + if (depth==1) RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; - /* Hook the tails of the branches to the closing node. */ - for (br = REGNODE_p(ret); br; br = regnext(br)) { - const U8 op = PL_regkind[OP(br)]; - if (op == BRANCH) { + /* Hook the tails of the branches to the closing node. */ + for (br = REGNODE_p(ret); br; br = regnext(br)) { + const U8 op = PL_regkind[OP(br)]; + if (op == BRANCH) { if (! REGTAIL_STUDY(pRExC_state, REGNODE_OFFSET(NEXTOPER(br)), ender)) @@ -12369,8 +12369,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) if ( OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != REGNODE_p(ender)) is_nothing= 0; - } - else if (op == BRANCHJ) { + } + else if (op == BRANCHJ) { bool shut_gcc_up = REGTAIL_STUDY(pRExC_state, REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))), ender); @@ -12380,8 +12380,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender)) */ is_nothing= 0; - } - } + } + } if (is_nothing) { regnode * ret_as_regnode = REGNODE_p(ret); br= PL_regkind[OP(ret_as_regnode)] != BRANCH @@ -12412,7 +12412,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) NEXT_OFF(br)= REGNODE_p(ender) - br; } } - } + } } { @@ -12421,47 +12421,47 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) static const char parens[] = "=!aA<,>Bbt"; /* flag below is set to 0 up through 'A'; 1 for larger */ - if (paren && (p = strchr(parens, paren))) { - U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH; - int flag = (p - parens) > 3; + if (paren && (p = strchr(parens, paren))) { + U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH; + int flag = (p - parens) > 3; - if (paren == '>' || paren == 't') { - node = SUSPEND, flag = 0; + if (paren == '>' || paren == 't') { + node = SUSPEND, flag = 0; } - reginsert(pRExC_state, node, ret, depth+1); + reginsert(pRExC_state, node, ret, depth+1); Set_Node_Cur_Length(REGNODE_p(ret), parse_start); - Set_Node_Offset(REGNODE_p(ret), parse_start + 1); - FLAGS(REGNODE_p(ret)) = flag; + Set_Node_Offset(REGNODE_p(ret), parse_start + 1); + FLAGS(REGNODE_p(ret)) = flag; if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL))) { REQUIRE_BRANCHJ(flagp, 0); } - } + } } /* Check for proper termination. */ if (paren) { /* restore original flags, but keep (?p) and, if we've encountered * something in the parse that changes /d rules into /u, keep the /u */ - RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY); + RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY); if (DEPENDS_SEMANTICS && toUSE_UNI_CHARSET_NOT_DEPENDS) { set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET); } - if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') { - RExC_parse = oregcomp_parse; - vFAIL("Unmatched ("); - } - nextchar(pRExC_state); + if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') { + RExC_parse = oregcomp_parse; + vFAIL("Unmatched ("); + } + nextchar(pRExC_state); } else if (!paren && RExC_parse < RExC_end) { - if (*RExC_parse == ')') { - RExC_parse++; - vFAIL("Unmatched )"); - } - else - FAIL("Junk on end of regexp"); /* "Can't happen". */ - NOT_REACHED; /* NOTREACHED */ + if (*RExC_parse == ')') { + RExC_parse++; + vFAIL("Unmatched )"); + } + else + FAIL("Junk on end of regexp"); /* "Can't happen". */ + NOT_REACHED; /* NOTREACHED */ } if (after_freeze > RExC_npar) @@ -12498,12 +12498,12 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) DEBUG_PARSE("brnc"); if (first) - ret = 0; + ret = 0; else { - if (RExC_use_BRANCHJ) - ret = reganode(pRExC_state, BRANCHJ, 0); - else { - ret = reg_node(pRExC_state, BRANCH); + if (RExC_use_BRANCHJ) + ret = reganode(pRExC_state, BRANCHJ, 0); + else { + ret = reg_node(pRExC_state, BRANCH); Set_Node_Length(REGNODE_p(ret), 1); } } @@ -12513,38 +12513,38 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') { - flags &= ~TRYAGAIN; + flags &= ~TRYAGAIN; latest = regpiece(pRExC_state, &flags, depth+1); - if (latest == 0) { - if (flags & TRYAGAIN) - continue; + if (latest == 0) { + if (flags & TRYAGAIN) + continue; RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags); - } - else if (ret == 0) + } + else if (ret == 0) ret = latest; - *flagp |= flags&(HASWIDTH|POSTPONED); - if (chain != 0) { - /* FIXME adding one for every branch after the first is probably - * excessive now we have TRIE support. (hv) */ - MARK_NAUGHTY(1); + *flagp |= flags&(HASWIDTH|POSTPONED); + if (chain != 0) { + /* FIXME adding one for every branch after the first is probably + * excessive now we have TRIE support. (hv) */ + MARK_NAUGHTY(1); if (! REGTAIL(pRExC_state, chain, latest)) { /* XXX We could just redo this branch, but figuring out what * bookkeeping needs to be reset is a pain, and it's likely * that other branches that goto END will also be too large */ REQUIRE_BRANCHJ(flagp, 0); } - } - chain = latest; - c++; + } + chain = latest; + c++; } if (chain == 0) { /* Loop ran zero times. */ - chain = reg_node(pRExC_state, NOTHING); - if (ret == 0) - ret = chain; + chain = reg_node(pRExC_state, NOTHING); + if (ret == 0) + ret = chain; } if (c == 1) { - *flagp |= flags&SIMPLE; + *flagp |= flags&SIMPLE; } return ret; @@ -12602,7 +12602,7 @@ Perl_regcurly(const char *s, const char *e, const char * result[5]) PERL_ARGS_ASSERT_REGCURLY; if (s >= e || *s++ != '{') - return FALSE; + return FALSE; while (s < e && isBLANK(*s)) { s++; @@ -12622,7 +12622,7 @@ Perl_regcurly(const char *s, const char *e, const char * result[5]) if (*s == ',') { has_comma = TRUE; - s++; + s++; while (s < e && isBLANK(*s)) { s++; @@ -13513,36 +13513,36 @@ S_backref_value(char *p, char *e) A summary of the code structure is: switch (first_byte) { - cases for each special: - handle this special; - break; - case '\\': - switch (2nd byte) { - cases for each unambiguous special: - handle this special; - break; - cases for each ambigous special/literal: - disambiguate; - if (special) handle here - else goto defchar; - default: // unambiguously literal: - goto defchar; - } - default: // is a literal char - // FALL THROUGH - defchar: - create EXACTish node for literal; - while (more input and node isn't full) { - switch (input_byte) { - cases for each special; + cases for each special: + handle this special; + break; + case '\\': + switch (2nd byte) { + cases for each unambiguous special: + handle this special; + break; + cases for each ambigous special/literal: + disambiguate; + if (special) handle here + else goto defchar; + default: // unambiguously literal: + goto defchar; + } + default: // is a literal char + // FALL THROUGH + defchar: + create EXACTish node for literal; + while (more input and node isn't full) { + switch (input_byte) { + cases for each special; make sure parse pointer is set so that the next call to regatom will see this special first goto loopdone; // EXACTish node terminated by prev. char - default: - append char to EXACTISH node; - } - get next input byte; - } + default: + append char to EXACTISH node; + } + get next input byte; + } loopdone: } return the generated node; @@ -13576,37 +13576,37 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) assert(RExC_parse < RExC_end); switch ((U8)*RExC_parse) { case '^': - RExC_seen_zerolen++; - nextchar(pRExC_state); - if (RExC_flags & RXf_PMf_MULTILINE) - ret = reg_node(pRExC_state, MBOL); - else - ret = reg_node(pRExC_state, SBOL); + RExC_seen_zerolen++; + nextchar(pRExC_state); + if (RExC_flags & RXf_PMf_MULTILINE) + ret = reg_node(pRExC_state, MBOL); + else + ret = reg_node(pRExC_state, SBOL); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '$': - nextchar(pRExC_state); - if (*RExC_parse) - RExC_seen_zerolen++; - if (RExC_flags & RXf_PMf_MULTILINE) - ret = reg_node(pRExC_state, MEOL); - else - ret = reg_node(pRExC_state, SEOL); + nextchar(pRExC_state); + if (*RExC_parse) + RExC_seen_zerolen++; + if (RExC_flags & RXf_PMf_MULTILINE) + ret = reg_node(pRExC_state, MEOL); + else + ret = reg_node(pRExC_state, SEOL); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '.': - nextchar(pRExC_state); - if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SANY); - else - ret = reg_node(pRExC_state, REG_ANY); - *flagp |= HASWIDTH|SIMPLE; - MARK_NAUGHTY(1); + nextchar(pRExC_state); + if (RExC_flags & RXf_PMf_SINGLELINE) + ret = reg_node(pRExC_state, SANY); + else + ret = reg_node(pRExC_state, REG_ANY); + *flagp |= HASWIDTH|SIMPLE; + MARK_NAUGHTY(1); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '[': { - char * const oregcomp_parse = ++RExC_parse; + char * const oregcomp_parse = ++RExC_parse; ret = regclass(pRExC_state, flagp, depth+1, FALSE, /* means parse the whole char class */ TRUE, /* allow multi-char folds */ @@ -13619,65 +13619,65 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf, (UV) *flagp); } - if (*RExC_parse != ']') { - RExC_parse = oregcomp_parse; - vFAIL("Unmatched ["); - } - nextchar(pRExC_state); + if (*RExC_parse != ']') { + RExC_parse = oregcomp_parse; + vFAIL("Unmatched ["); + } + nextchar(pRExC_state); Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */ - break; + break; } case '(': - nextchar(pRExC_state); + nextchar(pRExC_state); ret = reg(pRExC_state, 2, &flags, depth+1); - if (ret == 0) { - if (flags & TRYAGAIN) { - if (RExC_parse >= RExC_end) { - /* Make parent create an empty node if needed. */ - *flagp |= TRYAGAIN; - return(0); - } - goto tryagain; - } + if (ret == 0) { + if (flags & TRYAGAIN) { + if (RExC_parse >= RExC_end) { + /* Make parent create an empty node if needed. */ + *flagp |= TRYAGAIN; + return(0); + } + goto tryagain; + } RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf, (UV) flags); - } - *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED); - break; + } + *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED); + break; case '|': case ')': - if (flags & TRYAGAIN) { - *flagp |= TRYAGAIN; - return 0; - } - vFAIL("Internal urp"); - /* Supposed to be caught earlier. */ - break; + if (flags & TRYAGAIN) { + *flagp |= TRYAGAIN; + return 0; + } + vFAIL("Internal urp"); + /* Supposed to be caught earlier. */ + break; case '?': case '+': case '*': - RExC_parse++; - vFAIL("Quantifier follows nothing"); - break; + RExC_parse++; + vFAIL("Quantifier follows nothing"); + break; case '\\': - /* Special Escapes - - This switch handles escape sequences that resolve to some kind - of special regop and not to literal text. Escape sequences that - resolve to literal text are handled below in the switch marked - "Literal Escapes". - - Every entry in this switch *must* have a corresponding entry - in the literal escape switch. However, the opposite is not - required, as the default for this switch is to jump to the - literal text handling code. - */ - RExC_parse++; - switch ((U8)*RExC_parse) { - /* Special Escapes */ - case 'A': - RExC_seen_zerolen++; + /* Special Escapes + + This switch handles escape sequences that resolve to some kind + of special regop and not to literal text. Escape sequences that + resolve to literal text are handled below in the switch marked + "Literal Escapes". + + Every entry in this switch *must* have a corresponding entry + in the literal escape switch. However, the opposite is not + required, as the default for this switch is to jump to the + literal text handling code. + */ + RExC_parse++; + switch ((U8)*RExC_parse) { + /* Special Escapes */ + case 'A': + RExC_seen_zerolen++; /* Under wildcards, this is changed to match \n; should be * invisible to the user, as they have to compile under /m */ if (RExC_pm_flags & PMf_WILDCARD) { @@ -13689,8 +13689,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * /\A/ from /^/ in split. */ FLAGS(REGNODE_p(ret)) = 1; } - goto finish_meta_pat; - case 'G': + goto finish_meta_pat; + case 'G': if (RExC_pm_flags & PMf_WILDCARD) { RExC_parse++; /* diag_listed_as: Use of %s is not allowed in Unicode property @@ -13699,10 +13699,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Use of '\\G' is not allowed in Unicode property" " wildcard subpatterns"); } - ret = reg_node(pRExC_state, GPOS); + ret = reg_node(pRExC_state, GPOS); RExC_seen |= REG_GPOS_SEEN; - goto finish_meta_pat; - case 'K': + goto finish_meta_pat; + case 'K': if (!RExC_in_lookaround) { RExC_seen_zerolen++; ret = reg_node(pRExC_state, KEEPS); @@ -13717,7 +13717,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ++RExC_parse; /* advance past the 'K' */ vFAIL("\\K not permitted in lookahead/lookbehind"); } - case 'Z': + case 'Z': if (RExC_pm_flags & PMf_WILDCARD) { /* See comment under \A above */ ret = reg_node(pRExC_state, MEOL); @@ -13725,9 +13725,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, SEOL); } - RExC_seen_zerolen++; /* Do not optimize RE away */ - goto finish_meta_pat; - case 'z': + RExC_seen_zerolen++; /* Do not optimize RE away */ + goto finish_meta_pat; + case 'z': if (RExC_pm_flags & PMf_WILDCARD) { /* See comment under \A above */ ret = reg_node(pRExC_state, MEOL); @@ -13735,28 +13735,28 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, EOS); } - RExC_seen_zerolen++; /* Do not optimize RE away */ - goto finish_meta_pat; - case 'C': - vFAIL("\\C no longer supported"); - case 'X': - ret = reg_node(pRExC_state, CLUMP); - *flagp |= HASWIDTH; - goto finish_meta_pat; + RExC_seen_zerolen++; /* Do not optimize RE away */ + goto finish_meta_pat; + case 'C': + vFAIL("\\C no longer supported"); + case 'X': + ret = reg_node(pRExC_state, CLUMP); + *flagp |= HASWIDTH; + goto finish_meta_pat; - case 'B': + case 'B': invert = 1; /* FALLTHROUGH */ - case 'b': + case 'b': { U8 flags = 0; - regex_charset charset = get_regex_charset(RExC_flags); + regex_charset charset = get_regex_charset(RExC_flags); - RExC_seen_zerolen++; + RExC_seen_zerolen++; RExC_seen |= REG_LOOKBEHIND_SEEN; - op = BOUND + charset; + op = BOUND + charset; - if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') { + if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') { flags = TRADITIONAL_BOUND; if (op > BOUNDA) { /* /aa is same as /a */ op = BOUNDA; @@ -13820,9 +13820,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) default: bad_bound_type: RExC_parse = e; - vFAIL2utf8f( + vFAIL2utf8f( "'%" UTF8f "' is an unknown bound type", - UTF8fARG(UTF, length, e - length)); + UTF8fARG(UTF, length, e - length)); NOT_REACHED; /*NOTREACHED*/ } RExC_parse = endbrace; @@ -13845,7 +13845,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ? ASCII_RESTRICT_PAT_MODS : ASCII_MORE_RESTRICT_PAT_MODS); } - } + } if (op == BOUND) { RExC_seen_d_op = TRUE; @@ -13858,29 +13858,29 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) op += NBOUND - BOUND; } - ret = reg_node(pRExC_state, op); + ret = reg_node(pRExC_state, op); FLAGS(REGNODE_p(ret)) = flags; - goto finish_meta_pat; + goto finish_meta_pat; } - case 'R': - ret = reg_node(pRExC_state, LNBREAK); - *flagp |= HASWIDTH|SIMPLE; - goto finish_meta_pat; - - case 'd': - case 'D': - case 'h': - case 'H': - case 'p': - case 'P': - case 's': - case 'S': - case 'v': - case 'V': - case 'w': - case 'W': + case 'R': + ret = reg_node(pRExC_state, LNBREAK); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + + case 'd': + case 'D': + case 'h': + case 'H': + case 'p': + case 'P': + case 's': + case 'S': + case 'v': + case 'V': + case 'w': + case 'W': /* These all have the same meaning inside [brackets], and it knows * how to do the best optimizations for them. So, pretend we found * these within brackets, and let it do the work */ @@ -13918,7 +13918,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Offset(REGNODE_p(ret), parse_start); Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); /* MJD */ nextchar(pRExC_state); - break; + break; case 'N': /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the * \N{...} evaluates to a sequence of more than one code points). @@ -13951,7 +13951,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) RExC_parse = parse_start; goto defchar; - case 'k': /* Handle \k and \k'NAME' and \k{NAME} */ + case 'k': /* Handle \k and \k'NAME' and \k{NAME} */ parse_named_seq: /* Also handle non-numeric \g{...} */ { char ch; @@ -13960,11 +13960,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) && ch != '\'' && ch != '{')) { - RExC_parse++; - /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */ - vFAIL2("Sequence %.2s... not terminated", parse_start); - } else { - RExC_parse += 2; + RExC_parse++; + /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */ + vFAIL2("Sequence %.2s... not terminated", parse_start); + } else { + RExC_parse += 2; if (ch == '{') { while (isBLANK(*RExC_parse)) { RExC_parse++; @@ -13980,21 +13980,21 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) : '\''); } break; - } - case 'g': - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - { - I32 num; - char * endbrace = NULL; + } + case 'g': + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + { + I32 num; + char * endbrace = NULL; char * s = RExC_parse; char * e = RExC_end; - if (*s == 'g') { + if (*s == 'g') { bool isrel = 0; - s++; - if (*s == '{') { + s++; + if (*s == '{') { endbrace = (char *) memchr(s, '}', RExC_end - s); if (! endbrace ) { @@ -14020,7 +14020,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Unterminated \\g{...} pattern"); } - s++; /* Past the '{' */ + s++; /* Past the '{' */ while (isBLANK(*s)) { s++; @@ -14031,18 +14031,18 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) while (s < e && isBLANK(*(e - 1))) { e--; } - } + } /* Here, have isolated the meat of the construct from any * surrounding braces */ - if (*s == '-') { - isrel = 1; - s++; - } + if (*s == '-') { + isrel = 1; + s++; + } - if (endbrace && !isDIGIT(*s)) { - goto parse_named_seq; + if (endbrace && !isDIGIT(*s)) { + goto parse_named_seq; } RExC_parse = s; @@ -14051,7 +14051,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Reference to invalid group 0"); else if (num == I32_MAX) { if (isDIGIT(*RExC_parse)) - vFAIL("Reference to nonexistent group"); + vFAIL("Reference to nonexistent group"); else vFAIL("Unterminated \\g... pattern"); } @@ -14139,48 +14139,48 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1); skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); - } - break; - case '\0': - if (RExC_parse >= RExC_end) - FAIL("Trailing \\"); - /* FALLTHROUGH */ - default: - /* Do not generate "unrecognized" warnings here, we fall - back into the quick-grab loop below */ + } + break; + case '\0': + if (RExC_parse >= RExC_end) + FAIL("Trailing \\"); + /* FALLTHROUGH */ + default: + /* Do not generate "unrecognized" warnings here, we fall + back into the quick-grab loop below */ RExC_parse = parse_start; - goto defchar; - } /* end of switch on a \foo sequence */ - break; + goto defchar; + } /* end of switch on a \foo sequence */ + break; case '#': /* '#' comments should have been spaced over before this function was * called */ assert((RExC_flags & RXf_PMf_EXTENDED) == 0); - /* + /* if (RExC_flags & RXf_PMf_EXTENDED) { - RExC_parse = reg_skipcomment( pRExC_state, RExC_parse ); - if (RExC_parse < RExC_end) - goto tryagain; - } + RExC_parse = reg_skipcomment( pRExC_state, RExC_parse ); + if (RExC_parse < RExC_end) + goto tryagain; + } */ - /* FALLTHROUGH */ + /* FALLTHROUGH */ default: - defchar: { + defchar: { /* Here, we have determined that the next thing is probably a * literal character. RExC_parse points to the first byte of its * definition. (It still may be an escape sequence that evaluates * to a single character) */ - STRLEN len = 0; - UV ender = 0; - char *p; - char *s, *old_s = NULL, *old_old_s = NULL; - char *s0; + STRLEN len = 0; + UV ender = 0; + char *p; + char *s, *old_s = NULL, *old_old_s = NULL; + char *s0; U32 max_string_len = 255; /* We may have to reparse the node, artificially stopping filling @@ -14254,11 +14254,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) FILL_NODE(ret, node_type); RExC_emit++; - s = STRING(REGNODE_p(ret)); + s = STRING(REGNODE_p(ret)); s0 = s; - reparse: + reparse: p = RExC_parse; len = 0; @@ -14300,7 +14300,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * The exceptions override this */ Size_t added_len = 1; - oldp = p; + oldp = p; old_old_s = old_s; old_s = s; @@ -14308,62 +14308,62 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) assert( (RExC_flags & RXf_PMf_EXTENDED) == 0 || ! is_PATWS_safe((p), RExC_end, UTF)); - switch ((U8)*p) { + switch ((U8)*p) { const char* message; U32 packed_warn; U8 grok_c_char; - case '^': - case '$': - case '.': - case '[': - case '(': - case ')': - case '|': - goto loopdone; - case '\\': - /* Literal Escapes Switch - - This switch is meant to handle escape sequences that - resolve to a literal character. - - Every escape sequence that represents something - else, like an assertion or a char class, is handled - in the switch marked 'Special Escapes' above in this - routine, but also has an entry here as anything that - isn't explicitly mentioned here will be treated as - an unescaped equivalent literal. - */ - - switch ((U8)*++p) { - - /* These are all the special escapes. */ - case 'A': /* Start assertion */ - case 'b': case 'B': /* Word-boundary assertion*/ - case 'C': /* Single char !DANGEROUS! */ - case 'd': case 'D': /* digit class */ - case 'g': case 'G': /* generic-backref, pos assertion */ - case 'h': case 'H': /* HORIZWS */ - case 'k': case 'K': /* named backref, keep marker */ - case 'p': case 'P': /* Unicode property */ - case 'R': /* LNBREAK */ - case 's': case 'S': /* space class */ - case 'v': case 'V': /* VERTWS */ - case 'w': case 'W': /* word class */ + case '^': + case '$': + case '.': + case '[': + case '(': + case ')': + case '|': + goto loopdone; + case '\\': + /* Literal Escapes Switch + + This switch is meant to handle escape sequences that + resolve to a literal character. + + Every escape sequence that represents something + else, like an assertion or a char class, is handled + in the switch marked 'Special Escapes' above in this + routine, but also has an entry here as anything that + isn't explicitly mentioned here will be treated as + an unescaped equivalent literal. + */ + + switch ((U8)*++p) { + + /* These are all the special escapes. */ + case 'A': /* Start assertion */ + case 'b': case 'B': /* Word-boundary assertion*/ + case 'C': /* Single char !DANGEROUS! */ + case 'd': case 'D': /* digit class */ + case 'g': case 'G': /* generic-backref, pos assertion */ + case 'h': case 'H': /* HORIZWS */ + case 'k': case 'K': /* named backref, keep marker */ + case 'p': case 'P': /* Unicode property */ + case 'R': /* LNBREAK */ + case 's': case 'S': /* space class */ + case 'v': case 'V': /* VERTWS */ + case 'w': case 'W': /* word class */ case 'X': /* eXtended Unicode "combining character sequence" */ - case 'z': case 'Z': /* End of line/string assertion */ - --p; - goto loopdone; - - /* Anything after here is an escape that resolves to a - literal. (Except digits, which may or may not) - */ - case 'n': - ender = '\n'; - p++; - break; - case 'N': /* Handle a single-code point named character. */ + case 'z': case 'Z': /* End of line/string assertion */ + --p; + goto loopdone; + + /* Anything after here is an escape that resolves to a + literal. (Except digits, which may or may not) + */ + case 'n': + ender = '\n'; + p++; + break; + case 'N': /* Handle a single-code point named character. */ RExC_parse = p + 1; if (! grok_bslash_N(pRExC_state, NULL, /* Fail if evaluates to @@ -14407,27 +14407,27 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } break; - case 'r': - ender = '\r'; - p++; - break; - case 't': - ender = '\t'; - p++; - break; - case 'f': - ender = '\f'; - p++; - break; - case 'e': - ender = ESC_NATIVE; - p++; - break; - case 'a': - ender = '\a'; - p++; - break; - case 'o': + case 'r': + ender = '\r'; + p++; + break; + case 't': + ender = '\t'; + p++; + break; + case 'f': + ender = '\f'; + p++; + break; + case 'e': + ender = ESC_NATIVE; + p++; + break; + case 'a': + ender = '\a'; + p++; + break; + case 'o': if (! grok_bslash_o(&p, RExC_end, &ender, @@ -14446,7 +14446,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) warn_non_literal_string(p, packed_warn, message); } break; - case 'x': + case 'x': if (! grok_bslash_x(&p, RExC_end, &ender, @@ -14473,7 +14473,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } #endif break; - case 'c': + case 'c': p++; if (! grok_bslash_c(*p, &grok_c_char, &message, &packed_warn)) @@ -14492,7 +14492,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) warn_non_literal_string(p, packed_warn, message); } - break; + break; case '8': case '9': /* must be a backreference */ --p; /* we have an escape like \8 which cannot be an octal escape @@ -14500,7 +14500,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * escape which may or may not be a legitimate backref. */ goto loopdone; case '1': case '2': case '3':case '4': - case '5': case '6': case '7': + case '5': case '6': case '7': /* When we parse backslash escapes there is ambiguity * between backreferences and octal escapes. Any escape @@ -14526,29 +14526,29 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '0': - { - I32 flags = PERL_SCAN_SILENT_ILLDIGIT + { + I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT; - STRLEN numlen = 3; - ender = grok_oct(p, &numlen, &flags, NULL); - p += numlen; + STRLEN numlen = 3; + ender = grok_oct(p, &numlen, &flags, NULL); + p += numlen; if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT) && isDIGIT(*p) /* like \08, \178 */ && ckWARN(WARN_REGEXP)) { - reg_warn_non_literal_string( + reg_warn_non_literal_string( p + 1, form_alien_digit_msg(8, numlen, p, RExC_end, UTF, FALSE)); } - } - break; - case '\0': - if (p >= RExC_end) - FAIL("Trailing \\"); - /* FALLTHROUGH */ - default: - if (isALPHANUMERIC(*p)) { + } + break; + case '\0': + if (p >= RExC_end) + FAIL("Trailing \\"); + /* FALLTHROUGH */ + default: + if (isALPHANUMERIC(*p)) { /* An alpha followed by '{' is going to fail next * iteration, so don't output this warning in that * case */ @@ -14556,11 +14556,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ckWARN2reg(p + 1, "Unrecognized escape \\%.1s" " passed through", p); } - } - goto normal_default; - } /* End of switch on '\' */ - break; - case '{': + } + goto normal_default; + } /* End of switch on '\' */ + break; + case '{': /* Trying to gain new uses for '{' without breaking too * much existing code is hard. The solution currently * adopted is: @@ -14576,7 +14576,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * misspelled the quantifier. Without this warning, * the quantifier would silently be taken as a literal * string of characters instead of a meta construct */ - if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) { + if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) { if ( RExC_strict || ( p > parse_start + 1 && isALPHA_A(*(p - 1)) @@ -14588,28 +14588,28 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } ckWARNreg(p + 1, "Unescaped left brace in regex is" " passed through"); - } - goto normal_default; + } + goto normal_default; case '}': case ']': if (p > RExC_parse && RExC_strict) { ckWARN2reg(p + 1, "Unescaped literal '%c'", *p); } - /*FALLTHROUGH*/ - default: /* A literal character */ - normal_default: - if (! UTF8_IS_INVARIANT(*p) && UTF) { - STRLEN numlen; - ender = utf8n_to_uvchr((U8*)p, RExC_end - p, - &numlen, UTF8_ALLOW_DEFAULT); - p += numlen; - } - else - ender = (U8) *p++; - break; - } /* End of switch on the literal */ - - /* Here, have looked at the literal character, and + /*FALLTHROUGH*/ + default: /* A literal character */ + normal_default: + if (! UTF8_IS_INVARIANT(*p) && UTF) { + STRLEN numlen; + ender = utf8n_to_uvchr((U8*)p, RExC_end - p, + &numlen, UTF8_ALLOW_DEFAULT); + p += numlen; + } + else + ender = (U8) *p++; + break; + } /* End of switch on the literal */ + + /* Here, have looked at the literal character, and * contains its ordinal;

points to the character after it. * */ @@ -14871,20 +14871,20 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * requires UTF-8 to represent. */ : (char) toLOWER_L1(ender); } - } /* End of adding current character to the node */ + } /* End of adding current character to the node */ done_with_this_char: len += added_len; - if (next_is_quantifier) { + if (next_is_quantifier) { /* Here, the next input is a quantifier, and to get here, * the current character is the only one in the node. */ goto loopdone; - } + } - } /* End of loop through literal characters */ + } /* End of loop through literal characters */ /* Here we have either exhausted the input or run out of room in * the node. If the former, we are done. (If we encountered a @@ -15374,7 +15374,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Safefree(locfold_buf); Safefree(loc_correspondence); } - } /* End of verifying node ends with an appropriate char */ + } /* End of verifying node ends with an appropriate char */ /* We need to start the next node at the character that didn't fit * in this one */ @@ -15498,15 +15498,15 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), p - parse_start - 1); RExC_parse = p; - { - /* len is STRLEN which is unsigned, need to copy to signed */ - IV iv = len; - if (iv < 0) - vFAIL("Internal disaster"); - } + { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + if (iv < 0) + vFAIL("Internal disaster"); + } - } /* End of label 'defchar:' */ - break; + } /* End of label 'defchar:' */ + break; } /* End of giant switch on input character */ /* Position parse to next real character */ @@ -15546,53 +15546,53 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) ANYOF_BITMAP_ZERO(node); if (*invlist_ptr) { - /* This gets set if we actually need to modify things */ - bool change_invlist = FALSE; + /* This gets set if we actually need to modify things */ + bool change_invlist = FALSE; - UV start, end; + UV start, end; - /* Start looking through *invlist_ptr */ - invlist_iterinit(*invlist_ptr); - while (invlist_iternext(*invlist_ptr, &start, &end)) { - UV high; - int i; + /* Start looking through *invlist_ptr */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { + UV high; + int i; if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) { ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP; } - /* Quit if are above what we should change */ - if (start >= NUM_ANYOF_CODE_POINTS) { - break; - } + /* Quit if are above what we should change */ + if (start >= NUM_ANYOF_CODE_POINTS) { + break; + } - change_invlist = TRUE; + change_invlist = TRUE; - /* Set all the bits in the range, up to the max that we are doing */ - high = (end < NUM_ANYOF_CODE_POINTS - 1) + /* Set all the bits in the range, up to the max that we are doing */ + high = (end < NUM_ANYOF_CODE_POINTS - 1) ? end : NUM_ANYOF_CODE_POINTS - 1; - for (i = start; i <= (int) high; i++) { + for (i = start; i <= (int) high; i++) { ANYOF_BITMAP_SET(node, i); - } - } - invlist_iterfinish(*invlist_ptr); + } + } + invlist_iterfinish(*invlist_ptr); /* Done with loop; remove any code points that are in the bitmap from * *invlist_ptr; similarly for code points above the bitmap if we have * a flag to match all of them anyways */ - if (change_invlist) { - _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); - } + if (change_invlist) { + _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); + } if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { - _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); - } + _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); + } - /* If have completely emptied it, remove it completely */ - if (_invlist_len(*invlist_ptr) == 0) { - SvREFCNT_dec_NN(*invlist_ptr); - *invlist_ptr = NULL; - } + /* If have completely emptied it, remove it completely */ + if (_invlist_len(*invlist_ptr) == 0) { + SvREFCNT_dec_NN(*invlist_ptr); + *invlist_ptr = NULL; + } } } @@ -16633,7 +16633,7 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, RExC_parse++; RExC_sets_depth++; - node = reg(pRExC_state, 2, flagp, depth+1); + node = reg(pRExC_state, 2, flagp, depth+1); RETURN_FAIL_ON_RESTART(*flagp, flagp); if ( OP(REGNODE_p(node)) != REGEX_SET @@ -17454,7 +17454,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, SV *listsv = NULL; /* List of \p{user-defined} whose definitions aren't available at the time this was called */ STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more - than just initialized. */ + than just initialized. */ SV* properties = NULL; /* Code points that match \p{} \P{} */ SV* posixes = NULL; /* Code points that match classes like [:word:], extended beyond the Latin1 range. These have to @@ -17471,7 +17471,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, leading to less compilation and execution work */ UV element_count = 0; /* Number of distinct elements in the class. - Optimizations may be possible if this is tiny */ + Optimizations may be possible if this is tiny */ AV * multi_char_matches = NULL; /* Code points that fold to more than one character; used under /i */ UV n; @@ -17574,7 +17574,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, assert(RExC_parse <= RExC_end); if (UCHARAT(RExC_parse) == '^') { /* Complement the class */ - RExC_parse++; + RExC_parse++; invert = TRUE; allow_mutiple_chars = FALSE; MARK_NAUGHTY(1); @@ -17609,7 +17609,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */ if (UCHARAT(RExC_parse) == ']') - goto charclassloop; + goto charclassloop; while (1) { @@ -17637,23 +17637,23 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, charclassloop: - namedclass = OOB_NAMEDCLASS; /* initialize as illegal */ + namedclass = OOB_NAMEDCLASS; /* initialize as illegal */ save_value = value; save_prevvalue = prevvalue; - if (!range) { - rangebegin = RExC_parse; - element_count++; + if (!range) { + rangebegin = RExC_parse; + element_count++; non_portable_endpoint = 0; - } - if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) { - value = utf8n_to_uvchr((U8*)RExC_parse, - RExC_end - RExC_parse, - &numlen, UTF8_ALLOW_DEFAULT); - RExC_parse += numlen; - } - else - value = UCHARAT(RExC_parse++); + } + if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) { + value = utf8n_to_uvchr((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, UTF8_ALLOW_DEFAULT); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); if (value == '[') { char * posix_class_end; @@ -17708,20 +17708,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, vFAIL("Unmatched ["); } - if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { - value = utf8n_to_uvchr((U8*)RExC_parse, - RExC_end - RExC_parse, - &numlen, UTF8_ALLOW_DEFAULT); - RExC_parse += numlen; - } - else - value = UCHARAT(RExC_parse++); + if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { + value = utf8n_to_uvchr((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, UTF8_ALLOW_DEFAULT); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); - /* Some compilers cannot handle switching on 64-bit integer - * values, therefore value cannot be an UV. Yes, this will - * be a problem later if we want switch on Unicode. - * A similar issue a little bit later when switching on - * namedclass. --jhi */ + /* Some compilers cannot handle switching on 64-bit integer + * values, therefore value cannot be an UV. Yes, this will + * be a problem later if we want switch on Unicode. + * A similar issue a little bit later when switching on + * namedclass. --jhi */ /* If the \ is escaping white space when white space is being * skipped, it means that that white space is wanted literally, and @@ -17732,16 +17732,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, U32 packed_warn; U8 grok_c_char; - case 'w': namedclass = ANYOF_WORDCHAR; break; - case 'W': namedclass = ANYOF_NWORDCHAR; break; - case 's': namedclass = ANYOF_SPACE; break; - case 'S': namedclass = ANYOF_NSPACE; break; - case 'd': namedclass = ANYOF_DIGIT; break; - case 'D': namedclass = ANYOF_NDIGIT; break; - case 'v': namedclass = ANYOF_VERTWS; break; - case 'V': namedclass = ANYOF_NVERTWS; break; - case 'h': namedclass = ANYOF_HORIZWS; break; - case 'H': namedclass = ANYOF_NHORIZWS; break; + case 'w': namedclass = ANYOF_WORDCHAR; break; + case 'W': namedclass = ANYOF_NWORDCHAR; break; + case 's': namedclass = ANYOF_SPACE; break; + case 'S': namedclass = ANYOF_NSPACE; break; + case 'd': namedclass = ANYOF_DIGIT; break; + case 'D': namedclass = ANYOF_NDIGIT; break; + case 'v': namedclass = ANYOF_VERTWS; break; + case 'V': namedclass = ANYOF_NVERTWS; break; + case 'h': namedclass = ANYOF_HORIZWS; break; + case 'H': namedclass = ANYOF_NHORIZWS; break; case 'N': /* Handle \N{NAME} in class */ { const char * const backslash_N_beg = RExC_parse - 2; @@ -17808,10 +17808,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, unicode_range = TRUE; /* \N{} are Unicode */ } break; - case 'p': - case 'P': - { - char *e; + case 'p': + case 'P': + { + char *e; if (RExC_pm_flags & PMf_WILDCARD) { RExC_parse++; @@ -17822,14 +17822,14 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, " wildcard subpatterns", (char) value, *(RExC_parse - 1)); } - /* \p means they want Unicode semantics */ - REQUIRE_UNI_RULES(flagp, 0); + /* \p means they want Unicode semantics */ + REQUIRE_UNI_RULES(flagp, 0); - if (RExC_parse >= RExC_end) - vFAIL2("Empty \\%c", (U8)value); - if (*RExC_parse == '{') { - const U8 c = (U8)value; - e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse); + if (RExC_parse >= RExC_end) + vFAIL2("Empty \\%c", (U8)value); + if (*RExC_parse == '{') { + const U8 c = (U8)value; + e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse); if (!e) { RExC_parse++; vFAIL2("Missing right brace on \\%c{}", c); @@ -17841,9 +17841,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * any '^', even when not under /x */ while (isSPACE(*RExC_parse)) { RExC_parse++; - } + } - if (UCHARAT(RExC_parse) == '^') { + if (UCHARAT(RExC_parse) == '^') { /* toggle. (The rhs xor gets the single bit that * differs between P and p; the other xor inverts just @@ -17859,12 +17859,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (e == RExC_parse) vFAIL2("Empty \\%c{}", c); - n = e - RExC_parse; - while (isSPACE(*(RExC_parse + n - 1))) - n--; + n = e - RExC_parse; + while (isSPACE(*(RExC_parse + n - 1))) + n--; - } /* The \p isn't immediately followed by a '{' */ - else if (! isALPHA(*RExC_parse)) { + } /* The \p isn't immediately followed by a '{' */ + else if (! isALPHA(*RExC_parse)) { RExC_parse += (UTF) ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; @@ -17873,10 +17873,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, (U8) value); } else { - e = RExC_parse; - n = 1; - } - { + e = RExC_parse; + n = 1; + } + { char* name = RExC_parse; /* Any message returned about expanding the definition */ @@ -17909,7 +17909,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, mojibake */ RExC_utf8 = TRUE; } - /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg))); } @@ -18027,30 +18027,30 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* Invert if asking for the complement */ if (value == 'P') { - _invlist_union_complement_2nd(properties, + _invlist_union_complement_2nd(properties, prop_definition, &properties); } else { _invlist_union(properties, prop_definition, &properties); - } + } } } - RExC_parse = e + 1; + RExC_parse = e + 1; namedclass = ANYOF_UNIPROP; /* no official name, but it's named */ - } - break; - case 'n': value = '\n'; break; - case 'r': value = '\r'; break; - case 't': value = '\t'; break; - case 'f': value = '\f'; break; - case 'b': value = '\b'; break; - case 'e': value = ESC_NATIVE; break; - case 'a': value = '\a'; break; - case 'o': - RExC_parse--; /* function expects to be pointed at the 'o' */ + } + break; + case 'n': value = '\n'; break; + case 'r': value = '\r'; break; + case 't': value = '\t'; break; + case 'f': value = '\f'; break; + case 'b': value = '\b'; break; + case 'e': value = ESC_NATIVE; break; + case 'a': value = '\a'; break; + case 'o': + RExC_parse--; /* function expects to be pointed at the 'o' */ if (! grok_bslash_o(&RExC_parse, RExC_end, &value, @@ -18070,9 +18070,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - case 'x': - RExC_parse--; /* function expects to be pointed at the 'x' */ + break; + case 'x': + RExC_parse--; /* function expects to be pointed at the 'x' */ if (! grok_bslash_x(&RExC_parse, RExC_end, &value, @@ -18092,8 +18092,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - case 'c': + break; + case 'c': if (! grok_bslash_c(*RExC_parse, &grok_c_char, &message, &packed_warn)) { @@ -18112,16 +18112,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } non_portable_endpoint++; - break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': - { - /* Take 1-3 octal digits */ - I32 flags = PERL_SCAN_SILENT_ILLDIGIT + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + { + /* Take 1-3 octal digits */ + I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT; numlen = (strict) ? 4 : 3; value = grok_oct(--RExC_parse, &numlen, &flags, NULL); - RExC_parse += numlen; + RExC_parse += numlen; if (numlen != 3) { if (strict) { RExC_parse += (UTF) @@ -18143,11 +18143,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - } - default: - /* Allow \_ to not give an error */ - if (isWORDCHAR(value) && value != '_') { + break; + } + default: + /* Allow \_ to not give an error */ + if (isWORDCHAR(value) && value != '_') { if (strict) { vFAIL2("Unrecognized escape \\%c in character class", (int)value); @@ -18157,20 +18157,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, "Unrecognized escape \\%c in character class passed through", (int)value); } - } - break; - } /* End of switch on char following backslash */ - } /* end of handling backslash escape sequences */ + } + break; + } /* End of switch on char following backslash */ + } /* end of handling backslash escape sequences */ /* Here, we have the current token in 'value' */ - if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ + if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ U8 classnum; - /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a - * literal, as is the character that began the false range, i.e. - * the 'a' in the examples */ - if (range) { + /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a + * literal, as is the character that began the false range, i.e. + * the 'a' in the examples */ + if (range) { const int w = (RExC_parse >= rangebegin) ? RExC_parse - rangebegin : 0; @@ -18188,13 +18188,13 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, prevvalue); } - range = 0; /* this was not a true range */ + range = 0; /* this was not a true range */ element_count += 2; /* So counts for three values */ - } + } classnum = namedclass_to_classnum(namedclass); - if (LOC && namedclass < ANYOF_POSIXL_MAX + if (LOC && namedclass < ANYOF_POSIXL_MAX #ifndef HAS_ISASCII && classnum != _CC_ASCII #endif @@ -18316,8 +18316,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, namedclass % 2 != 0, posixes_ptr); } - } - } /* end of namedclass \blah */ + } + } /* end of namedclass \blah */ SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end); @@ -18330,20 +18330,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * the next real character to be processed is the range indicator--the * minus sign */ - if (range) { + if (range) { #ifdef EBCDIC /* For unicode ranges, we have to test that the Unicode as opposed * to the native values are not decreasing. (Above 255, there is * no difference between native and Unicode) */ - if (unicode_range && prevvalue < 255 && value < 255) { + if (unicode_range && prevvalue < 255 && value < 255) { if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) { goto backwards_range; } } else #endif - if (prevvalue > value) /* b-a */ { - int w; + if (prevvalue > value) /* b-a */ { + int w; #ifdef EBCDIC backwards_range: #endif @@ -18352,9 +18352,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, "Invalid [] range \"%" UTF8f "\"", UTF8fARG(UTF, w, rangebegin)); NOT_REACHED; /* NOTREACHED */ - } - } - else { + } + } + else { prevvalue = value; /* save the beginning of the potential range */ if (! stop_at_1 /* Can't be a range if parsing just one thing */ && *RExC_parse == '-') @@ -18391,8 +18391,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, range = 1; /* yeah, it's a range! */ continue; /* but do it the next time */ } - } - } + } + } if (namedclass > OOB_NAMEDCLASS) { continue; @@ -18402,8 +18402,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * is the beginning of the range, if any; or if * not. */ - /* non-Latin1 code point implies unicode semantics. */ - if (value > 255) { + /* non-Latin1 code point implies unicode semantics. */ + if (value > 255) { if (value > MAX_LEGAL_CP && ( value != UV_MAX || prevvalue > MAX_LEGAL_CP)) { @@ -18419,7 +18419,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, PL_extended_cp_format, value); } - } + } /* Ready to process either the single value, or the completed range. * For single-valued non-inverted ranges, we consider the possibility @@ -18656,7 +18656,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } #endif - range = 0; /* this range (if it was one) is done now */ + range = 0; /* this range (if it was one) is done now */ } /* End of loop through all the text within the brackets */ if ( posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) { @@ -18667,12 +18667,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * deal with them by building up a substitute parse string, and recursively * calling reg() on it, instead of proceeding */ if (multi_char_matches) { - SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP); + SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP); I32 cp_count; - STRLEN len; - char *save_end = RExC_end; - char *save_parse = RExC_parse; - char *save_start = RExC_start; + STRLEN len; + char *save_end = RExC_end; + char *save_parse = RExC_parse; + char *save_start = RExC_start; Size_t constructed_prefix_len = 0; /* This gives the length of the constructed portion of the substitute parse. */ @@ -18750,20 +18750,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * reported. See the comments at the definition of * REPORT_LOCATION_ARGS for details */ RExC_copy_start_in_input = (char *) orig_parse; - RExC_start = RExC_parse = SvPV(substitute_parse, len); + RExC_start = RExC_parse = SvPV(substitute_parse, len); RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len; - RExC_end = RExC_parse + len; + RExC_end = RExC_parse + len; RExC_in_multi_char_class = 1; - ret = reg(pRExC_state, 1, ®_flags, depth+1); + ret = reg(pRExC_state, 1, ®_flags, depth+1); *flagp |= reg_flags & (HASWIDTH|SIMPLE|POSTPONED|RESTART_PARSE|NEED_UTF8); /* And restore so can parse the rest of the pattern */ RExC_parse = save_parse; - RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start; - RExC_end = save_end; - RExC_in_multi_char_class = 0; + RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start; + RExC_end = save_end; + RExC_in_multi_char_class = 0; SvREFCNT_dec_NN(multi_char_matches); SvREFCNT_dec(properties); SvREFCNT_dec(cp_list); @@ -18915,7 +18915,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* Now that we have finished adding all the folds, there is no reason * to keep the foldable list separate */ _invlist_union(cp_list, cp_foldable_list, &cp_list); - SvREFCNT_dec_NN(cp_foldable_list); + SvREFCNT_dec_NN(cp_foldable_list); } /* And combine the result (if any) with any inversion lists from posix @@ -19151,8 +19151,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, { _invlist_invert(cp_list); - /* Clear the invert flag since have just done it here */ - invert = FALSE; + /* Clear the invert flag since have just done it here */ + invert = FALSE; } /* All possible optimizations below still have these characteristics. @@ -20098,15 +20098,15 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * when the target string is UTF-8 (). * */ if (upper_latin1_only_utf8_matches) { - if (cp_list) { - _invlist_union(cp_list, + if (cp_list) { + _invlist_union(cp_list, upper_latin1_only_utf8_matches, &cp_list); - SvREFCNT_dec_NN(upper_latin1_only_utf8_matches); - } - else { - cp_list = upper_latin1_only_utf8_matches; - } + SvREFCNT_dec_NN(upper_latin1_only_utf8_matches); + } + else { + cp_list = upper_latin1_only_utf8_matches; + } ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP; } @@ -20162,11 +20162,11 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) { assert(! (ANYOF_FLAGS(node) & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)); - ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); + ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); } else { - AV * const av = newAV(); - SV *rv; + AV * const av = newAV(); + SV *rv; if (cp_list) { av_store(av, INVLIST_INDEX, SvREFCNT_inc_NN(cp_list)); @@ -20185,10 +20185,10 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, SvREFCNT_inc_NN(runtime_defns)); } - rv = newRV_noinc(MUTABLE_SV(av)); - n = add_data(pRExC_state, STR_WITH_LEN("s")); - RExC_rxi->data->data[n] = (void*)rv; - ARG_SET(node, n); + rv = newRV_noinc(MUTABLE_SV(av)); + n = add_data(pRExC_state, STR_WITH_LEN("s")); + RExC_rxi->data->data[n] = (void*)rv; + ARG_SET(node, n); } } @@ -20242,12 +20242,12 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, assert(! output_invlist || listsvp); if (data && data->count) { - const U32 n = ARG(node); + const U32 n = ARG(node); - if (data->what[n] == 's') { - SV * const rv = MUTABLE_SV(data->data[n]); - AV * const av = MUTABLE_AV(SvRV(rv)); - SV **const ary = AvARRAY(av); + if (data->what[n] == 's') { + SV * const rv = MUTABLE_SV(data->data[n]); + AV * const av = MUTABLE_AV(SvRV(rv)); + SV **const ary = AvARRAY(av); invlist = ary[INVLIST_INDEX]; @@ -20259,7 +20259,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, si = ary[DEFERRED_USER_DEFINED_INDEX]; } - if (doinit && (si || invlist)) { + if (doinit && (si || invlist)) { if (si) { bool user_defined; SV * msg = newSVpvs_flags("", SVs_TEMP); @@ -20301,20 +20301,20 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, : INVLIST_INDEX); si = NULL; } - } - } + } + } } /* If requested, return a printable version of what this ANYOF node matches * */ if (listsvp) { - SV* matches_string = NULL; + SV* matches_string = NULL; /* This function can be called at compile-time, before everything gets * resolved, in which case we return the currently best available * information, which is the string that will eventually be used to do * that resolving, 'si' */ - if (si) { + if (si) { /* Here, we only have 'si' (and possibly some passed-in data in * 'invlist', which is handled below) If the caller only wants * 'si', use that. */ @@ -20413,7 +20413,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, SvCUR_set(matches_string, SvCUR(matches_string) - 1); } } /* end of has an 'si' */ - } + } /* Add the stuff that's already known */ if (invlist) { @@ -20436,7 +20436,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, } } - *listsvp = matches_string; + *listsvp = matches_string; } return invlist; @@ -20492,21 +20492,21 @@ S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p)); for (;;) { - if (RExC_end - (*p) >= 3 - && *(*p) == '(' - && *(*p + 1) == '?' - && *(*p + 2) == '#') - { - while (*(*p) != ')') { - if ((*p) == RExC_end) - FAIL("Sequence (?#... not terminated"); - (*p)++; - } - (*p)++; - continue; - } - - if (use_xmod) { + if (RExC_end - (*p) >= 3 + && *(*p) == '(' + && *(*p + 1) == '?' + && *(*p + 2) == '#') + { + while (*(*p) != ')') { + if ((*p) == RExC_end) + FAIL("Sequence (?#... not terminated"); + (*p)++; + } + (*p)++; + continue; + } + + if (use_xmod) { const char * save_p = *p; while ((*p) < RExC_end) { STRLEN len; @@ -20523,7 +20523,7 @@ S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, if (*p != save_p) { continue; } - } + } break; } @@ -20577,7 +20577,7 @@ S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const Ptrdiff_t size) char, regexp_internal); if ( RExC_rxi == NULL ) - FAIL("Regexp out of space"); + FAIL("Regexp out of space"); RXi_SET(RExC_rx, RExC_rxi); RExC_emit_start = RExC_rxi->program; @@ -20618,16 +20618,16 @@ S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_ assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF); if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n", name, __LINE__, PL_reg_name[op], (UV)(RExC_emit) > RExC_offsets[0] - ? "Overwriting end of array!\n" : "OK", + ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit), (UV)(RExC_parse - RExC_start), (UV)RExC_offsets[0])); - Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END)); + Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END)); } #endif return(ret); @@ -20772,21 +20772,21 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op, RExC_end_op += size; while (src > REGNODE_p(operand)) { - StructCopy(--src, --dst, regnode); + StructCopy(--src, --dst, regnode); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD 20010112 */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n", "reginsert", - __LINE__, - PL_reg_name[op], + __LINE__, + PL_reg_name[op], (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0] - ? "Overwriting end of array!\n" : "OK", + ? "Overwriting end of array!\n" : "OK", (UV)REGNODE_OFFSET(src), (UV)REGNODE_OFFSET(dst), (UV)RExC_offsets[0])); - Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src)); - Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src)); + Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src)); + Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src)); } #endif } @@ -20794,18 +20794,18 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op, place = REGNODE_p(operand); /* Op node, where operand used to be. */ #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n", "reginsert", - __LINE__, - PL_reg_name[op], + __LINE__, + PL_reg_name[op], (UV)REGNODE_OFFSET(place) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)REGNODE_OFFSET(place), (UV)(RExC_parse - RExC_start), (UV)RExC_offsets[0])); - Set_Node_Offset(place, RExC_parse); - Set_Node_Length(place, 1); + Set_Node_Offset(place, RExC_parse); + Set_Node_Length(place, 1); } #endif src = NEXTOPER(place); @@ -20841,7 +20841,7 @@ S_regtail(pTHX_ RExC_state_t * pRExC_state, * */ scan = (regnode_offset) p; for (;;) { - regnode * const temp = regnext(REGNODE_p(scan)); + regnode * const temp = regnext(REGNODE_p(scan)); DEBUG_PARSE_r({ DEBUG_PARSE_MSG((scan==p ? "tail" : "")); regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state); @@ -20918,11 +20918,11 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, regnode * const temp = regnext(REGNODE_p(scan)); #ifdef EXPERIMENTAL_INPLACESCAN if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) { - bool unfolded_multi_char; /* Unexamined in this routine */ + bool unfolded_multi_char; /* Unexamined in this routine */ if (join_exact(pRExC_state, scan, &min, &unfolded_multi_char, 1, REGNODE_p(val), depth+1)) return TRUE; /* Was return EXACT */ - } + } #endif if ( exact ) { if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) { @@ -20943,23 +20943,23 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, scan, PL_reg_name[exact]); }); - if (temp == NULL) - break; - scan = REGNODE_OFFSET(temp); + if (temp == NULL) + break; + scan = REGNODE_OFFSET(temp); } DEBUG_PARSE_r({ DEBUG_PARSE_MSG(""); regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state); Perl_re_printf( aTHX_ "~ attach to %s (%" IVdf ") offset to %" IVdf "\n", - SvPV_nolen_const(RExC_mysv), - (IV)val, - (IV)(val - scan) + SvPV_nolen_const(RExC_mysv), + (IV)val, + (IV)(val - scan) ); }); if (reg_off_by_arg[OP(REGNODE_p(scan))]) { assert((UV) (val - scan) <= U32_MAX); - ARG_SET(REGNODE_p(scan), val - scan); + ARG_SET(REGNODE_p(scan), val - scan); } else { if (val - scan > U16_MAX) { @@ -20969,7 +20969,7 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, NEXT_OFF(REGNODE_p(scan)) = U16_MAX; return FALSE; } - NEXT_OFF(REGNODE_p(scan)) = val - scan; + NEXT_OFF(REGNODE_p(scan)) = val - scan; } return TRUE; /* Was 'return exact' */ @@ -21048,9 +21048,9 @@ S_regdump_extflags(pTHX_ const char *lead, const U32 flags) for (bit=0; bitcheck_substr || r->check_utf8) Perl_re_printf( aTHX_ - (const char *) - ( r->check_substr == r->substrs->data[1].substr - && r->check_utf8 == r->substrs->data[1].utf8_substr - ? "(checking floating" : "(checking anchored")); + (const char *) + ( r->check_substr == r->substrs->data[1].substr + && r->check_utf8 == r->substrs->data[1].utf8_substr + ? "(checking floating" : "(checking anchored")); if (r->intflags & PREGf_NOSCAN) Perl_re_printf( aTHX_ " noscan"); if (r->extflags & RXf_CHECK_ALL) @@ -21257,29 +21257,29 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ k = PL_regkind[OP(o)]; if (k == EXACT) { - sv_catpvs(sv, " "); - /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) - * is a crude hack but it may be the best for now since - * we have no flag "this EXACTish node was UTF-8" - * --jhi */ - pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len, + sv_catpvs(sv, " "); + /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) + * is a crude hack but it may be the best for now since + * we have no flag "this EXACTish node was UTF-8" + * --jhi */ + pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len, PL_colors[0], PL_colors[1], - PERL_PV_ESCAPE_UNI_DETECT | - PERL_PV_ESCAPE_NONASCII | - PERL_PV_PRETTY_ELLIPSES | - PERL_PV_PRETTY_LTGT | - PERL_PV_PRETTY_NOCLEAR - ); + PERL_PV_ESCAPE_UNI_DETECT | + PERL_PV_ESCAPE_NONASCII | + PERL_PV_PRETTY_ELLIPSES | + PERL_PV_PRETTY_LTGT | + PERL_PV_PRETTY_NOCLEAR + ); } else if (k == TRIE) { - /* print the details of the trie in dumpuntil instead, as - * progi->data isn't available here */ + /* print the details of the trie in dumpuntil instead, as + * progi->data isn't available here */ const char op = OP(o); const U32 n = ARG(o); const reg_ac_data * const ac = IS_TRIE_AC(op) ? (reg_ac_data *)progi->data->data[n] : NULL; const reg_trie_data * const trie - = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; + = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]); DEBUG_TRIE_COMPILE_r({ @@ -21312,8 +21312,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } else if (k == CURLY) { U32 lo = ARG1(o), hi = ARG2(o); - if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) - Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ + if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) + Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo); if (hi == REG_INFTY) sv_catpvs(sv, "INFTY"); @@ -21322,14 +21322,14 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpvs(sv, "}"); } else if (k == WHILEM && o->flags) /* Ordinal/of */ - Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); + Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { AV *name_list= NULL; U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o); Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno); /* Parenth number */ - if ( RXp_PAREN_NAMES(prog) ) { + if ( RXp_PAREN_NAMES(prog) ) { name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); } else if ( pRExC_state ) { name_list= RExC_paren_name_list; @@ -21337,8 +21337,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (name_list) { if ( k != REF || (OP(o) < REFN)) { SV **name= av_fetch(name_list, parno, 0 ); - if (name) - Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); + if (name) + Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); } else { SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]); @@ -21387,7 +21387,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } else if (k == LOGICAL) /* 2: embedded, otherwise 1 */ - Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); + Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); else if (k == ANYOF || k == ANYOFR) { U8 flags; char * bitmap; @@ -21419,7 +21419,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ arg = ARG(o); } - if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) { + if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) { if (ANYOFL_UTF8_LOCALE_REQD(flags)) { sv_catpvs(sv, "{utf8-locale-reqd}"); } @@ -21473,7 +21473,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } /* Ready to start outputting. First, the initial left bracket */ - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); + Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); /* ANYOFH by definition doesn't have anything that will fit inside the * bitmap; ANYOFR may or may not. */ @@ -21578,7 +21578,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } /* And finally the matching, closing ']' */ - Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); if (OP(o) == ANYOFHs) { Perl_sv_catpvf(aTHX_ sv, " (Leading UTF-8 bytes=%s", _byte_dump_string((U8 *) ((struct regnode_anyofhs *) o)->string, FLAGS(o), 1)); @@ -21609,13 +21609,13 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ else if (k == ANYOFM) { SV * cp_list = get_ANYOFM_contents(o); - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); + Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); if (OP(o) == NANYOFM) { _invlist_invert(cp_list); } put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, 0, TRUE); - Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); SvREFCNT_dec(cp_list); } @@ -21647,11 +21647,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpv(sv, bounds[FLAGS(o)]); } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) { - Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags)); + Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags)); if (o->next_off) { Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off); } - Perl_sv_catpvf(aTHX_ sv, "]"); + Perl_sv_catpvf(aTHX_ sv, "]"); } else if (OP(o) == SBOL) Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); @@ -21691,22 +21691,22 @@ Perl_re_intuit_string(pTHX_ REGEXP * const r) PERL_UNUSED_CONTEXT; DEBUG_COMPILE_r( - { + { if (prog->maxlen > 0) { const char * const s = SvPV_nolen_const(RX_UTF8(r) - ? prog->check_utf8 : prog->check_substr); + ? prog->check_utf8 : prog->check_substr); if (!PL_colorset) reginitcolors(); Perl_re_printf( aTHX_ - "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n", - PL_colors[4], - RX_UTF8(r) ? "utf8 " : "", - PL_colors[5], PL_colors[0], - s, - PL_colors[1], - (strlen(s) > PL_dump_re_max_len ? "..." : "")); + "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n", + PL_colors[4], + RX_UTF8(r) ? "utf8 " : "", + PL_colors[5], PL_colors[0], + s, + PL_colors[1], + (strlen(s) > PL_dump_re_max_len ? "..." : "")); } - } ); + } ); /* use UTF8 check substring if regexp pattern itself is in UTF8 */ return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr; @@ -21754,7 +21754,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx) SvREFCNT_dec(r->substrs->data[i].substr); SvREFCNT_dec(r->substrs->data[i].utf8_substr); } - Safefree(r->substrs); + Safefree(r->substrs); } RX_MATCH_COPY_FREE(rx); #ifdef PERL_ANY_COW @@ -21801,7 +21801,7 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) PERL_ARGS_ASSERT_REG_TEMP_COPY; if (!dsv) - dsv = (REGEXP*) newSV_type(SVt_REGEXP); + dsv = (REGEXP*) newSV_type(SVt_REGEXP); else { assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV)); @@ -21818,22 +21818,22 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) } SvLEN_set(dsv, 0); SvCUR_set(dsv, 0); - SvOK_off((SV *)dsv); + SvOK_off((SV *)dsv); - if (islv) { - /* For PVLVs, the head (sv_any) points to an XPVLV, while + if (islv) { + /* For PVLVs, the head (sv_any) points to an XPVLV, while * the LV's xpvlenu_rx will point to a regexp body, which * we allocate here */ - REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP); - assert(!SvPVX(dsv)); + REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP); + assert(!SvPVX(dsv)); ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any; - temp->sv_any = NULL; - SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL; - SvREFCNT_dec_NN(temp); - /* SvCUR still resides in the xpvlv struct, so the regexp copy- - ing below will not set it. */ - SvCUR_set(dsv, SvCUR(ssv)); - } + temp->sv_any = NULL; + SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL; + SvREFCNT_dec_NN(temp); + /* SvCUR still resides in the xpvlv struct, so the regexp copy- + ing below will not set it. */ + SvCUR_set(dsv, SvCUR(ssv)); + } } /* This ensures that SvTHINKFIRST(sv) is true, and hence that sv_force_normal(sv) is called. */ @@ -21847,7 +21847,7 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) The string pointer is copied here, being part of the regexp struct. */ memcpy(&(drx->xpv_cur), &(srx->xpv_cur), - sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)); + sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)); if (!islv) SvLEN_set(dsv, 0); if (srx->offs) { @@ -21858,15 +21858,15 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) if (srx->substrs) { int i; Newx(drx->substrs, 1, struct reg_substr_data); - StructCopy(srx->substrs, drx->substrs, struct reg_substr_data); + StructCopy(srx->substrs, drx->substrs, struct reg_substr_data); for (i = 0; i < 2; i++) { SvREFCNT_inc_void(drx->substrs->data[i].substr); SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr); } - /* check_substr and check_utf8, if non-NULL, point to either their - anchored or float namesakes, and don't hold a second reference. */ + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ } RX_MATCH_COPIED_off(dsv); #ifdef PERL_ANY_COW @@ -21908,10 +21908,10 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } DEBUG_COMPILE_r({ - if (!PL_colorset) - reginitcolors(); - { - SV *dsv= sv_newmortal(); + if (!PL_colorset) + reginitcolors(); + { + SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RX_UTF8(rx), dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len); Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n", @@ -21927,24 +21927,24 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) S_free_codeblocks(aTHX_ ri->code_blocks); if (ri->data) { - int n = ri->data->count; + int n = ri->data->count; - while (--n >= 0) { + while (--n >= 0) { /* If you add a ->what type here, update the comment in regcomp.h */ - switch (ri->data->what[n]) { - case 'a': - case 'r': - case 's': - case 'S': - case 'u': - SvREFCNT_dec(MUTABLE_SV(ri->data->data[n])); - break; - case 'f': - Safefree(ri->data->data[n]); - break; - case 'l': - case 'L': - break; + switch (ri->data->what[n]) { + case 'a': + case 'r': + case 's': + case 'S': + case 'u': + SvREFCNT_dec(MUTABLE_SV(ri->data->data[n])); + break; + case 'f': + Safefree(ri->data->data[n]); + break; + case 'l': + case 'L': + break; case 'T': { /* Aho Corasick add-on structure for a trie node. Used in stclass optimization only */ @@ -21956,7 +21956,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) if ( !refcount ) { PerlMemShared_free(aho->states); PerlMemShared_free(aho->fail); - /* do this last!!!! */ + /* do this last!!!! */ PerlMemShared_free(ri->data->data[n]); /* we should only ever get called once, so * assert as much, and also guard the free @@ -21971,11 +21971,11 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } } break; - case 't': - { - /* trie structure. */ - U32 refcount; - reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; + case 't': + { + /* trie structure. */ + U32 refcount; + reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; OP_REFCNT_LOCK; refcount = --trie->refcount; OP_REFCNT_UNLOCK; @@ -21987,19 +21987,19 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) PerlMemShared_free(trie->bitmap); if (trie->jump) PerlMemShared_free(trie->jump); - PerlMemShared_free(trie->wordinfo); + PerlMemShared_free(trie->wordinfo); /* do this last!!!! */ PerlMemShared_free(ri->data->data[n]); - } - } - break; - default: - Perl_croak(aTHX_ "panic: regfree data code '%c'", + } + } + break; + default: + Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]); - } - } - Safefree(ri->data->what); - Safefree(ri->data); + } + } + Safefree(ri->data->what); + Safefree(ri->data); } Safefree(ri); @@ -22041,15 +22041,15 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) Copy(r->offs, ret->offs, npar, regexp_paren_pair); if (ret->substrs) { - /* Do it this way to avoid reading from *r after the StructCopy(). - That way, if any of the sv_dup_inc()s dislodge *r from the L1 - cache, it doesn't matter. */ + /* Do it this way to avoid reading from *r after the StructCopy(). + That way, if any of the sv_dup_inc()s dislodge *r from the L1 + cache, it doesn't matter. */ int i; - const bool anchored = r->check_substr - ? r->check_substr == r->substrs->data[0].substr - : r->check_utf8 == r->substrs->data[0].utf8_substr; + const bool anchored = r->check_substr + ? r->check_substr == r->substrs->data[0].substr + : r->check_utf8 == r->substrs->data[0].utf8_substr; Newx(ret->substrs, 1, struct reg_substr_data); - StructCopy(r->substrs, ret->substrs, struct reg_substr_data); + StructCopy(r->substrs, ret->substrs, struct reg_substr_data); for (i = 0; i < 2; i++) { ret->substrs->data[i].substr = @@ -22058,29 +22058,29 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) sv_dup_inc(ret->substrs->data[i].utf8_substr, param); } - /* check_substr and check_utf8, if non-NULL, point to either their - anchored or float namesakes, and don't hold a second reference. */ + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ - if (ret->check_substr) { - if (anchored) { - assert(r->check_utf8 == r->substrs->data[0].utf8_substr); + if (ret->check_substr) { + if (anchored) { + assert(r->check_utf8 == r->substrs->data[0].utf8_substr); - ret->check_substr = ret->substrs->data[0].substr; - ret->check_utf8 = ret->substrs->data[0].utf8_substr; - } else { - assert(r->check_substr == r->substrs->data[1].substr); - assert(r->check_utf8 == r->substrs->data[1].utf8_substr); + ret->check_substr = ret->substrs->data[0].substr; + ret->check_utf8 = ret->substrs->data[0].utf8_substr; + } else { + assert(r->check_substr == r->substrs->data[1].substr); + assert(r->check_utf8 == r->substrs->data[1].utf8_substr); - ret->check_substr = ret->substrs->data[1].substr; - ret->check_utf8 = ret->substrs->data[1].utf8_substr; - } - } else if (ret->check_utf8) { - if (anchored) { - ret->check_utf8 = ret->substrs->data[0].utf8_substr; - } else { - ret->check_utf8 = ret->substrs->data[1].utf8_substr; - } - } + ret->check_substr = ret->substrs->data[1].substr; + ret->check_utf8 = ret->substrs->data[1].utf8_substr; + } + } else if (ret->check_utf8) { + if (anchored) { + ret->check_utf8 = ret->substrs->data[0].utf8_substr; + } else { + ret->check_utf8 = ret->substrs->data[1].utf8_substr; + } + } } RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param); @@ -22089,12 +22089,12 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) Newx(ret->recurse_locinput, r->nparens + 1, char *); if (ret->pprivate) - RXi_SET(ret, CALLREGDUPE_PVT(dstr, param)); + RXi_SET(ret, CALLREGDUPE_PVT(dstr, param)); if (RX_MATCH_COPIED(dstr)) - ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); + ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); else - ret->subbeg = NULL; + ret->subbeg = NULL; #ifdef PERL_ANY_COW ret->saved_copy = NULL; #endif @@ -22102,9 +22102,9 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) /* Whether mother_re be set or no, we need to copy the string. We cannot refrain from copying it when the storage points directly to our mother regexp, because that's - 1: a buffer in a different thread - 2: something we no longer hold a reference on - so we need to copy it locally. */ + 1: a buffer in a different thread + 2: something we no longer hold a reference on + so we need to copy it locally. */ RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1); /* set malloced length to a non-zero value so it will be freed * (otherwise in combination with SVf_FAKE it looks like an alien @@ -22147,37 +22147,37 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) if (ri->code_blocks) { - int n; - Newx(reti->code_blocks, 1, struct reg_code_blocks); - Newx(reti->code_blocks->cb, ri->code_blocks->count, + int n; + Newx(reti->code_blocks, 1, struct reg_code_blocks); + Newx(reti->code_blocks->cb, ri->code_blocks->count, struct reg_code_block); - Copy(ri->code_blocks->cb, reti->code_blocks->cb, + Copy(ri->code_blocks->cb, reti->code_blocks->cb, ri->code_blocks->count, struct reg_code_block); - for (n = 0; n < ri->code_blocks->count; n++) - reti->code_blocks->cb[n].src_regex = (REGEXP*) - sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param); + for (n = 0; n < ri->code_blocks->count; n++) + reti->code_blocks->cb[n].src_regex = (REGEXP*) + sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param); reti->code_blocks->count = ri->code_blocks->count; reti->code_blocks->refcnt = 1; } else - reti->code_blocks = NULL; + reti->code_blocks = NULL; reti->regstclass = NULL; if (ri->data) { - struct reg_data *d; + struct reg_data *d; const int count = ri->data->count; - int i; + int i; - Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), - char, struct reg_data); - Newx(d->what, count, U8); + Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), + char, struct reg_data); + Newx(d->what, count, U8); - d->count = count; - for (i = 0; i < count; i++) { - d->what[i] = ri->data->what[i]; - switch (d->what[i]) { - /* see also regcomp.h and regfree_internal() */ + d->count = count; + for (i = 0; i < count; i++) { + d->what[i] = ri->data->what[i]; + switch (d->what[i]) { + /* see also regcomp.h and regfree_internal() */ case 'a': /* actually an AV, but the dup function is identical. values seem to be "plain sv's" generally. */ case 'r': /* a compiled regex (but still just another SV) */ @@ -22187,9 +22187,9 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) case 'S': /* actually an SV, but the dup function is identical. */ case 'u': /* actually an HV, but the dup function is identical. values are "plain sv's" */ - d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param); - break; - case 'f': + d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param); + break; + case 'f': /* Synthetic Start Class - "Fake" charclass we generate to optimize * patterns which could start with several different things. Pre-TRIE * this was more important than it is now, however this still helps @@ -22197,40 +22197,40 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass() * in regexec.c */ - /* This is cheating. */ - Newx(d->data[i], 1, regnode_ssc); - StructCopy(ri->data->data[i], d->data[i], regnode_ssc); - reti->regstclass = (regnode*)d->data[i]; - break; - case 'T': + /* This is cheating. */ + Newx(d->data[i], 1, regnode_ssc); + StructCopy(ri->data->data[i], d->data[i], regnode_ssc); + reti->regstclass = (regnode*)d->data[i]; + break; + case 'T': /* AHO-CORASICK fail table */ /* Trie stclasses are readonly and can thus be shared - * without duplication. We free the stclass in pregfree - * when the corresponding reg_ac_data struct is freed. - */ - reti->regstclass= ri->regstclass; - /* FALLTHROUGH */ - case 't': + * without duplication. We free the stclass in pregfree + * when the corresponding reg_ac_data struct is freed. + */ + reti->regstclass= ri->regstclass; + /* FALLTHROUGH */ + case 't': /* TRIE transition table */ - OP_REFCNT_LOCK; - ((reg_trie_data*)ri->data->data[i])->refcount++; - OP_REFCNT_UNLOCK; - /* FALLTHROUGH */ + OP_REFCNT_LOCK; + ((reg_trie_data*)ri->data->data[i])->refcount++; + OP_REFCNT_UNLOCK; + /* FALLTHROUGH */ case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */ case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code is not from another regexp */ - d->data[i] = ri->data->data[i]; - break; + d->data[i] = ri->data->data[i]; + break; default: Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'", ri->data->what[i]); - } - } + } + } - reti->data = d; + reti->data = d; } else - reti->data = NULL; + reti->data = NULL; reti->name_list_idx = ri->name_list_idx; @@ -22259,16 +22259,16 @@ Perl_regnext(pTHX_ regnode *p) I32 offset; if (!p) - return(NULL); + return(NULL); if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */ - Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", + Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX); } offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p)); if (offset == 0) - return(NULL); + return(NULL); return(p+offset); } @@ -22287,7 +22287,7 @@ S_re_croak(pTHX_ bool utf8, const char* pat,...) PERL_ARGS_ASSERT_RE_CROAK; if (len > 510) - len = 510; + len = 510; Copy(pat, buf, len , char); buf[len] = '\n'; buf[len + 1] = '\0'; @@ -22296,7 +22296,7 @@ S_re_croak(pTHX_ bool utf8, const char* pat,...) va_end(args); message = SvPV_const(msv, len); if (len > 512) - len = 512; + len = 512; Copy(message, buf, len , char); /* len-1 to avoid \n */ Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, len-1, buf)); @@ -22314,8 +22314,8 @@ Perl_save_re_context(pTHX) /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) + const REGEXP * const rx = PM_GETRE(PL_curpm); + if (rx) nparens = RX_NPARENS(rx); } @@ -22354,13 +22354,13 @@ S_put_code_point(pTHX_ SV *sv, UV c) Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c); } else if (isPRINT(c)) { - const char string = (char) c; + const char string = (char) c; /* We use {phrase} as metanotation in the class, so also escape literal * braces */ - if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}') - sv_catpvs(sv, "\\"); - sv_catpvn(sv, &string, 1); + if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}') + sv_catpvs(sv, "\\"); + sv_catpvn(sv, &string, 1); } else if (isMNEMONIC_CNTRL(c)) { Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c)); @@ -22927,10 +22927,10 @@ S_put_charclass_bitmap_innards(pTHX_ SV *sv, || ( SvCUR(inverted_display) + inverted_bias < SvCUR(as_is_display) + as_is_bias))) { - sv_catsv(sv, inverted_display); + sv_catsv(sv, inverted_display); } else if (as_is_display) { - sv_catsv(sv, as_is_display); + sv_catsv(sv, as_is_display); } SvREFCNT_dec(as_is_display); @@ -22959,8 +22959,8 @@ S_put_charclass_bitmap_innards(pTHX_ SV *sv, STATIC const regnode * S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, - const regnode *last, const regnode *plast, - SV* sv, I32 indent, U32 depth) + const regnode *last, const regnode *plast, + SV* sv, I32 indent, U32 depth) { U8 op = PSEUDO; /* Arbitrary non-END op. */ const regnode *next; @@ -22981,25 +22981,25 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, while (PL_regkind[op] != END && (!last || node < last)) { assert(node); - /* While that wasn't END last time... */ - NODE_ALIGN(node); - op = OP(node); - if (op == CLOSE || op == SRCLOSE || op == WHILEM) - indent--; - next = regnext((regnode *)node); - - /* Where, what. */ - if (OP(node) == OPTIMIZED) { - if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE)) - optstart = node; - else - goto after_print; - } else - CLEAR_OPTSTART; + /* While that wasn't END last time... */ + NODE_ALIGN(node); + op = OP(node); + if (op == CLOSE || op == SRCLOSE || op == WHILEM) + indent--; + next = regnext((regnode *)node); + + /* Where, what. */ + if (OP(node) == OPTIMIZED) { + if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE)) + optstart = node; + else + goto after_print; + } else + CLEAR_OPTSTART; regprop(r, sv, node, NULL, NULL); Perl_re_printf( aTHX_ "%4" IVdf ":%*s%s", (IV)(node - start), - (int)(2*indent + 1), "", SvPVX_const(sv)); + (int)(2*indent + 1), "", SvPVX_const(sv)); if (OP(node) != OPTIMIZED) { if (next == NULL) /* Next ptr. */ @@ -23013,39 +23013,39 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } after_print: - if (PL_regkind[(U8)op] == BRANCHJ) { - assert(next); - { + if (PL_regkind[(U8)op] == BRANCHJ) { + assert(next); + { const regnode *nnode = (OP(next) == LONGJMP ? regnext((regnode *)next) : next); if (last && nnode > last) nnode = last; DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode); - } - } - else if (PL_regkind[(U8)op] == BRANCH) { - assert(next); - DUMPUNTIL(NEXTOPER(node), next); - } - else if ( PL_regkind[(U8)op] == TRIE ) { - const regnode *this_trie = node; - const char op = OP(node); + } + } + else if (PL_regkind[(U8)op] == BRANCH) { + assert(next); + DUMPUNTIL(NEXTOPER(node), next); + } + else if ( PL_regkind[(U8)op] == TRIE ) { + const regnode *this_trie = node; + const char op = OP(node); const U32 n = ARG(node); - const reg_ac_data * const ac = op>=AHOCORASICK ? + const reg_ac_data * const ac = op>=AHOCORASICK ? (reg_ac_data *)ri->data->data[n] : NULL; - const reg_trie_data * const trie = - (reg_trie_data*)ri->data->data[optrie]; + const reg_trie_data * const trie = + (reg_trie_data*)ri->data->data[optrie]; #ifdef DEBUGGING - AV *const trie_words + AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]); #endif - const regnode *nextbranch= NULL; - I32 word_idx; + const regnode *nextbranch= NULL; + I32 word_idx; SvPVCLEAR(sv); - for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { - SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0); + for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { + SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0); Perl_re_indentf( aTHX_ "%s ", indent+3, @@ -23068,41 +23068,41 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, if (dist) { if (!nextbranch) nextbranch= this_trie + trie->jump[0]; - DUMPUNTIL(this_trie + dist, nextbranch); + DUMPUNTIL(this_trie + dist, nextbranch); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) nextbranch= regnext((regnode *)nextbranch); } else { Perl_re_printf( aTHX_ "\n"); - } - } - if (last && next > last) - node= last; - else - node= next; - } - else if ( op == CURLY ) { /* "next" might be very big: optimizer */ - DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, + } + } + if (last && next > last) + node= last; + else + node= next; + } + else if ( op == CURLY ) { /* "next" might be very big: optimizer */ + DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, NEXTOPER(node) + EXTRA_STEP_2ARGS + 1); - } - else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) { - assert(next); - DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next); - } - else if ( op == PLUS || op == STAR) { - DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1); - } - else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) { + } + else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) { + assert(next); + DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next); + } + else if ( op == PLUS || op == STAR) { + DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1); + } + else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) { /* Literal string, where present. */ - node += NODE_SZ_STR(node) - 1; - node = NEXTOPER(node); - } - else { - node = NEXTOPER(node); - node += regarglen[(U8)op]; - } - if (op == CURLYX || op == OPEN || op == SROPEN) - indent++; + node += NODE_SZ_STR(node) - 1; + node = NEXTOPER(node); + } + else { + node = NEXTOPER(node); + node += regarglen[(U8)op]; + } + if (op == CURLYX || op == OPEN || op == SROPEN) + indent++; } CLEAR_OPTSTART; #ifdef DEBUG_DUMPUNTIL @@ -23363,7 +23363,7 @@ S_compile_wildcard(pTHX_ const char * subpattern, const STRLEN len, STATIC I32 S_execute_wildcard(pTHX_ REGEXP * const prog, char* stringarg, char *strend, - char *strbeg, SSize_t minend, SV *screamer, U32 nosave) + char *strbeg, SSize_t minend, SV *screamer, U32 nosave) { I32 result; DECLARE_AND_GET_RE_DEBUG_FLAGS; @@ -25057,7 +25057,7 @@ S_parse_uniprop_string(pTHX_ COPHH * hinthash = (IN_PERL_COMPILETIME) ? CopHINTHASH_get(&PL_compiling) : CopHINTHASH_get(PL_curcop); - SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0); + SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0); if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) { diff --git a/regen/embed.pl b/regen/embed.pl index df4e692ac5f2..26fd30bc4d26 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -166,9 +166,9 @@ sub open_print_header { for my $arg ( @args ) { ++$n; if ( $args_assert_line - && $arg =~ /\*/ - && $arg !~ /\b(NN|NULLOK)\b/ ) - { + && $arg =~ /\*/ + && $arg !~ /\b(NN|NULLOK)\b/ ) + { warn "$func: $arg needs NN or NULLOK\n"; ++$unflagged_pointers; } diff --git a/regen/feature.pl b/regen/feature.pl index 1186cc3d03e5..0e0958bd7516 100755 --- a/regen/feature.pl +++ b/regen/feature.pl @@ -108,13 +108,13 @@ BEGIN for( sort keys %feature_bundle ) { my $value = join(' ', sort @{$feature_bundle{$_}}); if (exists $UniqueBundles{$value}) { - $Aliases{$_} = $UniqueBundles{$value}; + $Aliases{$_} = $UniqueBundles{$value}; } else { - $UniqueBundles{$value} = $_; + $UniqueBundles{$value} = $_; } } - # start end + # start end my %BundleRanges; # say => ['5.10', '5.15'] # unique bundles for values for my $bund ( sort { $a eq 'default' ? -1 : $b eq 'default' ? 1 : $a cmp $b } @@ -122,12 +122,12 @@ BEGIN ) { next if $bund =~ /[^\d.]/ and $bund ne 'default'; for (@{$feature_bundle{$bund}}) { - if (@{$BundleRanges{$_} ||= []} == 2) { - $BundleRanges{$_}[1] = $bund - } - else { - push @{$BundleRanges{$_}}, $bund; - } + if (@{$BundleRanges{$_} ||= []} == 2) { + $BundleRanges{$_}[1] = $bund + } + else { + push @{$BundleRanges{$_}}, $bund; + } } } @@ -141,19 +141,19 @@ BEGIN my $is_u8b = $1 =~ 8; /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n "; if ($is_u8b) { - $Uni8Bit = $1; + $Uni8Bit = $1; } else { - my $hex = $HintMask = $1; - my $bits = sprintf "%b", oct $1; - $bits =~ /^0*1+(0*)\z/ - or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n "; - $HintShift = length $1; - my $bits_needed = - length sprintf "%b", scalar keys %UniqueBundles; - $bits =~ /1{$bits_needed}/ - or die "Not enough bits (need $bits_needed)" - . " in $bits (binary for $hex):\n\n$_\n "; + my $hex = $HintMask = $1; + my $bits = sprintf "%b", oct $1; + $bits =~ /^0*1+(0*)\z/ + or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n "; + $HintShift = length $1; + my $bits_needed = + length sprintf "%b", scalar keys %UniqueBundles; + $bits =~ /1{$bits_needed}/ + or die "Not enough bits (need $bits_needed)" + . " in $bits (binary for $hex):\n\n$_\n "; } if ($Uni8Bit && $HintMask) { last } } @@ -185,9 +185,9 @@ BEGIN sub longest { my $long; for(@_) { - if (!defined $long or length $long < length) { - $long = $_; - } + if (!defined $long or length $long < length) { + $long = $_; + } } $long; } @@ -196,7 +196,7 @@ sub longest { my $width = length longest keys %feature; for(sort { length $a <=> length $b || $a cmp $b } keys %feature) { print $pm " $_" . " "x($width-length) - . " => 'feature_$feature{$_}',\n"; + . " => 'feature_$feature{$_}',\n"; } print $pm ");\n\n"; @@ -206,13 +206,13 @@ sub longest { keys %UniqueBundles ) { my $bund = $UniqueBundles{$_}; print $pm qq' "$bund"' . " "x($bund_width-length $bund) - . qq' => [qw($_)],\n'; + . qq' => [qw($_)],\n'; } print $pm ");\n\n"; for (sort keys %Aliases) { print $pm - qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n'; + qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n'; }; print $pm "my \%noops = (\n"; @@ -312,49 +312,49 @@ sub longest { sort { length $a <=> length $b || $a cmp $b } keys %feature ) { my($first,$last) = - map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}}; + map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}}; my $name = $feature{$_}; my $NAME = uc $name; if ($last && $first eq 'DEFAULT') { # '>= DEFAULT' warns - print $h <= FEATURE_BUNDLE_$first && \\ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\ + (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_$first && \\ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\ - FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT)) \\ + FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT)) \\ ) EOH3 } elsif ($first) { - print $h < 5.011 (my $macrover = $_) =~ y/.//d; print $h <<" EOK"; - (sv_setnv(comp_ver, $numver), - vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) - ? FEATURE_BUNDLE_$macrover : + (sv_setnv(comp_ver, $numver), + vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) + ? FEATURE_BUNDLE_$macrover : EOK } print $h < for details. @@ -919,8 +919,8 @@ sub unimport { # A bare C should reset to the default bundle if (!@_) { - $^H &= ~($hint_uni8bit|$hint_mask); - return; + $^H &= ~($hint_uni8bit|$hint_mask); + return; } __common(0, @_); @@ -933,14 +933,14 @@ sub __common { my $features = $bundle_number != $hint_mask && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; if ($features) { - # Features are enabled implicitly via bundle hints. - # Delete any keys that may be left over from last time. - delete @^H{ values(%feature) }; - $^H |= $hint_mask; - for (@$features) { - $^H{$feature{$_}} = 1; - $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; - } + # Features are enabled implicitly via bundle hints. + # Delete any keys that may be left over from last time. + delete @^H{ values(%feature) }; + $^H |= $hint_mask; + for (@$features) { + $^H{$feature{$_}} = 1; + $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; + } } while (@_) { my $name = shift; @@ -964,10 +964,10 @@ sub __common { } unknown_feature($name); } - if ($import) { - $^H{$feature{$name}} = 1; - $^H |= $hint_uni8bit if $name eq 'unicode_strings'; - } else { + if ($import) { + $^H{$feature{$name}} = 1; + $^H |= $hint_uni8bit if $name eq 'unicode_strings'; + } else { delete $^H{$feature{$name}}; $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; } diff --git a/regexec.c b/regexec.c index 452a298b9ba8..16f79e6c56d8 100644 --- a/regexec.c +++ b/regexec.c @@ -129,18 +129,18 @@ static const char non_utf8_target_but_utf8_required[] #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv)) #define HOPc(pos,off) \ - (char *)(reginfo->is_utf8_target \ - ? reghop3((U8*)pos, off, \ + (char *)(reginfo->is_utf8_target \ + ? reghop3((U8*)pos, off, \ (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ - : (U8*)(pos + off)) + : (U8*)(pos + off)) /* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */ #define HOPBACK3(pos, off, lim) \ - (reginfo->is_utf8_target \ - ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \ - : (pos - off >= lim) \ - ? (U8*)pos - off \ - : NULL) + (reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \ + : (pos - off >= lim) \ + ? (U8*)pos - off \ + : NULL) #define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg)) @@ -149,11 +149,11 @@ static const char non_utf8_target_but_utf8_required[] /* lim must be +ve. Returns NULL on overshoot */ #define HOPMAYBE3(pos,off,lim) \ - (reginfo->is_utf8_target \ - ? reghopmaybe3((U8*)pos, off, (U8*)(lim)) \ - : ((U8*)pos + off <= lim) \ - ? (U8*)pos + off \ - : NULL) + (reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, off, (U8*)(lim)) \ + : ((U8*)pos + off <= lim) \ + ? (U8*)pos + off \ + : NULL) /* like HOP3, but limits the result to <= lim even for the non-utf8 case. * off must be >=0; args should be vars rather than expressions */ @@ -200,14 +200,14 @@ static const char non_utf8_target_but_utf8_required[] */ #define FIND_NEXT_IMPT(rn) STMT_START { \ while (JUMPABLE(rn)) { \ - const OPCODE type = OP(rn); \ - if (type == SUSPEND || PL_regkind[type] == CURLY) \ - rn = NEXTOPER(NEXTOPER(rn)); \ - else if (type == PLUS) \ - rn = NEXTOPER(rn); \ - else if (type == IFMATCH) \ - rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \ - else rn += NEXT_OFF(rn); \ + const OPCODE type = OP(rn); \ + if (type == SUSPEND || PL_regkind[type] == CURLY) \ + rn = NEXTOPER(NEXTOPER(rn)); \ + else if (type == PLUS) \ + rn = NEXTOPER(rn); \ + else if (type == IFMATCH) \ + rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \ + else rn += NEXT_OFF(rn); \ } \ } STMT_END @@ -243,36 +243,36 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen _pDEPTH) (int)parenfloor, (unsigned)REGCP_PAREN_ELEMS); if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems) - Perl_croak(aTHX_ "panic: paren_elems_to_push offset %" UVuf - " out of range (%lu-%ld)", - total_elems, + Perl_croak(aTHX_ "panic: paren_elems_to_push offset %" UVuf + " out of range (%lu-%ld)", + total_elems, (unsigned long)maxopenparen, (long)parenfloor); SSGROW(total_elems + REGCP_FRAME_ELEMS); DEBUG_BUFFERS_r( - if ((int)maxopenparen > (int)parenfloor) + if ((int)maxopenparen > (int)parenfloor) Perl_re_exec_indentf( aTHX_ - "rex=0x%" UVxf " offs=0x%" UVxf ": saving capture indices:\n", - depth, + "rex=0x%" UVxf " offs=0x%" UVxf ": saving capture indices:\n", + depth, PTR2UV(rex), - PTR2UV(rex->offs) - ); + PTR2UV(rex->offs) + ); ); for (p = parenfloor+1; p <= (I32)maxopenparen; p++) { /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ - SSPUSHIV(rex->offs[p].end); - SSPUSHIV(rex->offs[p].start); - SSPUSHINT(rex->offs[p].start_tmp); + SSPUSHIV(rex->offs[p].end); + SSPUSHIV(rex->offs[p].start); + SSPUSHINT(rex->offs[p].start_tmp); DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ - " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "\n", - depth, + " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "\n", + depth, (UV)p, - (IV)rex->offs[p].start, - (IV)rex->offs[p].start_tmp, - (IV)rex->offs[p].end - )); + (IV)rex->offs[p].start, + (IV)rex->offs[p].start_tmp, + (IV)rex->offs[p].end + )); } /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ SSPUSHINT(maxopenparen); @@ -358,32 +358,32 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p _pDEPTH) i -= REGCP_OTHER_ELEMS; /* Now restore the parentheses context. */ DEBUG_BUFFERS_r( - if (i || rex->lastparen + 1 <= rex->nparens) + if (i || rex->lastparen + 1 <= rex->nparens) Perl_re_exec_indentf( aTHX_ - "rex=0x%" UVxf " offs=0x%" UVxf ": restoring capture indices to:\n", - depth, + "rex=0x%" UVxf " offs=0x%" UVxf ": restoring capture indices to:\n", + depth, PTR2UV(rex), - PTR2UV(rex->offs) - ); + PTR2UV(rex->offs) + ); ); paren = *maxopenparen_p; for ( ; i > 0; i -= REGCP_PAREN_ELEMS) { - SSize_t tmps; - rex->offs[paren].start_tmp = SSPOPINT; - rex->offs[paren].start = SSPOPIV; - tmps = SSPOPIV; - if (paren <= rex->lastparen) - rex->offs[paren].end = tmps; + SSize_t tmps; + rex->offs[paren].start_tmp = SSPOPINT; + rex->offs[paren].start = SSPOPIV; + tmps = SSPOPIV; + if (paren <= rex->lastparen) + rex->offs[paren].end = tmps; DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_ - " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "%s\n", - depth, + " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "%s\n", + depth, (UV)paren, - (IV)rex->offs[paren].start, - (IV)rex->offs[paren].start_tmp, - (IV)rex->offs[paren].end, - (paren > rex->lastparen ? "(skipped)" : "")); - ); - paren--; + (IV)rex->offs[paren].start, + (IV)rex->offs[paren].start_tmp, + (IV)rex->offs[paren].end, + (paren > rex->lastparen ? "(skipped)" : "")); + ); + paren--; } #if 1 /* It would seem that the similar code in regtry() @@ -396,15 +396,15 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p _pDEPTH) * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/ * --jhi updated by dapm */ for (i = rex->lastparen + 1; i <= rex->nparens; i++) { - if (i > *maxopenparen_p) - rex->offs[i].start = -1; - rex->offs[i].end = -1; + if (i > *maxopenparen_p) + rex->offs[i].start = -1; + rex->offs[i].end = -1; DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_ - " \\%" UVuf ": %s ..-1 undeffing\n", - depth, + " \\%" UVuf ": %s ..-1 undeffing\n", + depth, (UV)i, - (i > *maxopenparen_p) ? "-1" : " " - )); + (i > *maxopenparen_p) ? "-1" : " " + )); } #endif } @@ -760,7 +760,7 @@ S_find_span_end_mask(U8 * s, const U8 * send, const U8 span_byte, const U8 mask) */ I32 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, - char *strbeg, SSize_t minend, SV *screamer, U32 nosave) + char *strbeg, SSize_t minend, SV *screamer, U32 nosave) /* stringarg: the point in the string at which to begin matching */ /* strend: pointer to null at end of string */ /* strbeg: real beginning of string */ @@ -772,8 +772,8 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, PERL_ARGS_ASSERT_PREGEXEC; return - regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL, - nosave ? 0 : REXEC_COPY_STR); + regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL, + nosave ? 0 : REXEC_COPY_STR); } #endif @@ -907,8 +907,8 @@ Perl_re_intuit_start(pTHX_ * them later after doing full char arithmetic */ if (prog->minlen > strend - strpos) { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ - " String too short...\n")); - goto fail; + " String too short...\n")); + goto fail; } RXp_MATCH_UTF8_set(prog, utf8_target); @@ -924,15 +924,15 @@ Perl_re_intuit_start(pTHX_ if (utf8_target) { if ((!prog->anchored_utf8 && prog->anchored_substr) || (!prog->float_utf8 && prog->float_substr)) - to_utf8_substr(prog); - check = prog->check_utf8; + to_utf8_substr(prog); + check = prog->check_utf8; } else { - if (!prog->check_substr && prog->check_utf8) { - if (! to_byte_substr(prog)) { + if (!prog->check_substr && prog->check_utf8) { + if (! to_byte_substr(prog)) { NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail); } } - check = prog->check_substr; + check = prog->check_substr; } /* dump the various substring data */ @@ -967,10 +967,10 @@ Perl_re_intuit_start(pTHX_ * /.*abc/, /.*abc/m: PREGf_IMPLICIT | PREGf_ANCH_MBOL * /.*abc/s: PREGf_IMPLICIT | PREGf_ANCH_SBOL */ - ml_anch = (prog->intflags & PREGf_ANCH_MBOL) + ml_anch = (prog->intflags & PREGf_ANCH_MBOL) && !(prog->intflags & PREGf_IMPLICIT); - if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) { + if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) { /* we are only allowed to match at BOS or \G */ /* trivially reject if there's a BOS anchor and we're not at BOS. @@ -986,8 +986,8 @@ Perl_re_intuit_start(pTHX_ { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Not at start...\n")); - goto fail; - } + goto fail; + } /* in the presence of an anchor, the anchored (relative to the * start of the regex) substr must also be anchored relative @@ -999,21 +999,21 @@ Perl_re_intuit_start(pTHX_ * caller will have set strpos=pos()-4; we look for the substr * at position pos()-4+1, which lines up with the "a" */ - if (prog->check_offset_min == prog->check_offset_max) { - /* Substring at constant offset from beg-of-str... */ - SSize_t slen = SvCUR(check); + if (prog->check_offset_min == prog->check_offset_max) { + /* Substring at constant offset from beg-of-str... */ + SSize_t slen = SvCUR(check); char *s = HOP3c(strpos, prog->check_offset_min, strend); DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Looking for check substr at fixed offset %" IVdf "...\n", (IV)prog->check_offset_min)); - if (SvTAIL(check)) { + if (SvTAIL(check)) { /* In this case, the regex is anchored at the end too. * Unless it's a multiline match, the lengths must match * exactly, give or take a \n. NB: slen >= 1 since * the last char of check is \n */ - if (!multiline + if (!multiline && ( strend - s > slen || strend - s < slen - 1 || (strend - s == slen && strend[-1] != '\n'))) @@ -1036,16 +1036,16 @@ Perl_re_intuit_start(pTHX_ check_at = s; goto success_at_start; - } - } + } + } } end_shift = prog->check_end_shift; #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ if (end_shift < 0) - Perl_croak(aTHX_ "panic: end_shift: %" IVdf " pattern:\n%s\n ", - (IV)end_shift, RX_PRECOMP(rx)); + Perl_croak(aTHX_ "panic: end_shift: %" IVdf " pattern:\n%s\n ", + (IV)end_shift, RX_PRECOMP(rx)); #endif restart: @@ -1118,7 +1118,7 @@ Perl_re_intuit_start(pTHX_ if (check_len > targ_len) { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ - "Target string too short to match required substring...\n")); + "Target string too short to match required substring...\n")); goto fail_finish; } @@ -1138,8 +1138,8 @@ Perl_re_intuit_start(pTHX_ } } - check_at = fbm_instr( start_point, end_point, - check, multiline ? FBMrf_MULTILINE : 0); + check_at = fbm_instr( start_point, end_point, + check, multiline ? FBMrf_MULTILINE : 0); DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " doing 'check' fbm scan, [%" IVdf "..%" IVdf "] gave %" IVdf "\n", @@ -1186,7 +1186,7 @@ Perl_re_intuit_start(pTHX_ if (prog->substrs->data[other_ix].utf8_substr || prog->substrs->data[other_ix].substr) { - /* Take into account the "other" substring. */ + /* Take into account the "other" substring. */ char *last, *last1; char *s; SV* must; @@ -1483,11 +1483,11 @@ Perl_re_intuit_start(pTHX_ /* XXX this value could be pre-computed */ const SSize_t cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT - ? (reginfo->is_utf8_pat + ? (reginfo->is_utf8_pat ? (SSize_t)utf8_distance(str + STR_LEN(progi->regstclass), str) : (SSize_t)STR_LEN(progi->regstclass)) - : 1); - char * endpos; + : 1); + char * endpos; char *s; /* latest pos that a matching float substr constrains rx start to */ char *rx_max_float = NULL; @@ -1505,22 +1505,22 @@ Perl_re_intuit_start(pTHX_ * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>. * Here are some old comments, which may or may not be correct: * - * minlen == 0 is possible if regstclass is \b or \B, - * and the fixed substr is ''$. + * minlen == 0 is possible if regstclass is \b or \B, + * and the fixed substr is ''$. * Since minlen is already taken into account, rx_origin+1 is * before strend; accidentally, minlen >= 1 guaranties no false * positives at rx_origin + 1 even for \b or \B. But (minlen? 1 : * 0) below assumes that regstclass does not come from lookahead... - * If regstclass takes bytelength more than 1: If charlength==1, OK. + * If regstclass takes bytelength more than 1: If charlength==1, OK. * This leaves EXACTF-ish only, which are dealt with in * find_byclass(). */ - if (prog->anchored_substr || prog->anchored_utf8 || ml_anch) + if (prog->anchored_substr || prog->anchored_utf8 || ml_anch) endpos = HOP3clim(rx_origin, (prog->minlen ? cl_l : 0), strend); else if (prog->float_substr || prog->float_utf8) { - rx_max_float = HOP3c(check_at, -start_shift, strbeg); - endpos = HOP3clim(rx_max_float, cl_l, strend); + rx_max_float = HOP3c(check_at, -start_shift, strbeg); + endpos = HOP3clim(rx_max_float, cl_l, strend); } else endpos= strend; @@ -1533,20 +1533,20 @@ Perl_re_intuit_start(pTHX_ s = find_byclass(prog, progi->regstclass, rx_origin, endpos, reginfo); - if (!s) { - if (endpos == strend) { + if (!s) { + if (endpos == strend) { DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ - " Could not match STCLASS...\n") ); - goto fail; - } + " Could not match STCLASS...\n") ); + goto fail; + } DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ " This position contradicts STCLASS...\n") ); if ((prog->intflags & PREGf_ANCH) && !ml_anch && !(prog->intflags & PREGf_IMPLICIT)) - goto fail; + goto fail; - /* Contradict one of substrings */ - if (prog->anchored_substr || prog->anchored_utf8) { + /* Contradict one of substrings */ + if (prog->anchored_substr || prog->anchored_utf8) { if (prog->substrs->check_ix == 1) { /* check is float */ /* Have both, check_string is floating */ assert(rx_origin + start_shift <= check_at); @@ -1569,7 +1569,7 @@ Perl_re_intuit_start(pTHX_ } } } - else { + else { /* float-only */ if (ml_anch) { @@ -1616,13 +1616,13 @@ Perl_re_intuit_start(pTHX_ (IV)(rx_origin - strbeg) )); goto restart; - } + } /* Success !!! */ - if (rx_origin != s) { + if (rx_origin != s) { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ - " By STCLASS: moving %ld --> %ld\n", + " By STCLASS: moving %ld --> %ld\n", (long)(rx_origin - strbeg), (long)(s - strbeg)) ); } @@ -1636,41 +1636,41 @@ Perl_re_intuit_start(pTHX_ /* Decide whether using the substrings helped */ if (rx_origin != strpos) { - /* Fixed substring is found far enough so that the match - cannot start at strpos. */ + /* Fixed substring is found far enough so that the match + cannot start at strpos. */ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " try at offset...\n")); - ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ + ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ } else { /* The found rx_origin position does not prohibit matching at * strpos, so calling intuit didn't gain us anything. Decrement * the BmUSEFUL() count on the check substring, and if we reach * zero, free it. */ - if (!(prog->intflags & PREGf_NAUGHTY) - && (utf8_target ? ( - prog->check_utf8 /* Could be deleted already */ - && --BmUSEFUL(prog->check_utf8) < 0 - && (prog->check_utf8 == prog->float_utf8) - ) : ( - prog->check_substr /* Could be deleted already */ - && --BmUSEFUL(prog->check_substr) < 0 - && (prog->check_substr == prog->float_substr) - ))) - { - /* If flags & SOMETHING - do not do it many times on the same match */ + if (!(prog->intflags & PREGf_NAUGHTY) + && (utf8_target ? ( + prog->check_utf8 /* Could be deleted already */ + && --BmUSEFUL(prog->check_utf8) < 0 + && (prog->check_utf8 == prog->float_utf8) + ) : ( + prog->check_substr /* Could be deleted already */ + && --BmUSEFUL(prog->check_substr) < 0 + && (prog->check_substr == prog->float_substr) + ))) + { + /* If flags & SOMETHING - do not do it many times on the same match */ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " ... Disabling check substring...\n")); - /* XXX Does the destruction order has to change with utf8_target? */ - SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); - SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); - prog->check_substr = prog->check_utf8 = NULL; /* disable */ - prog->float_substr = prog->float_utf8 = NULL; /* clear */ - check = NULL; /* abort */ - /* XXXX This is a remnant of the old implementation. It - looks wasteful, since now INTUIT can use many - other heuristics. */ - prog->extflags &= ~RXf_USE_INTUIT; - } + /* XXX Does the destruction order has to change with utf8_target? */ + SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); + SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); + prog->check_substr = prog->check_utf8 = NULL; /* disable */ + prog->float_substr = prog->float_utf8 = NULL; /* clear */ + check = NULL; /* abort */ + /* XXXX This is a remnant of the old implementation. It + looks wasteful, since now INTUIT can use many + other heuristics. */ + prog->extflags &= ~RXf_USE_INTUIT; + } } DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ @@ -1681,10 +1681,10 @@ Perl_re_intuit_start(pTHX_ fail_finish: /* Substring not found */ if (prog->check_substr || prog->check_utf8) /* could be removed already */ - BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ + BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ fail: DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch rejected by optimizer%s\n", - PL_colors[4], PL_colors[5])); + PL_colors[4], PL_colors[5])); return NULL; } @@ -2075,10 +2075,10 @@ S_get_break_val_cp_checked(SV* const invlist, const UV cp_in) { return cp_out; } # define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \ - invmap[S_get_break_val_cp_checked(invlist, cp)] + invmap[S_get_break_val_cp_checked(invlist, cp)] #else # define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \ - invmap[_invlist_search(invlist, cp)] + invmap[_invlist_search(invlist, cp)] #endif /* Takes a pointer to an inversion list, a pointer to its corresponding @@ -2086,7 +2086,7 @@ S_get_break_val_cp_checked(SV* const invlist, const UV cp_in) { * according to the two arrays. It assumes that all code points have a value. * This is used as the base macro for macros for particular properties */ #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp) \ - _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) + _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead * of a code point, returning the value for the first code point in the string. @@ -2972,7 +2972,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, case LNBREAK_tb_pb: case LNBREAK_tb_p8: - REXEC_FBC_NON_UTF8_CLASS_SCAN(is_LNBREAK_latin1_safe(s, strend)); + REXEC_FBC_NON_UTF8_CLASS_SCAN(is_LNBREAK_latin1_safe(s, strend)); break; /* The argument to all the POSIX node types is the class number to pass @@ -3511,7 +3511,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, */ I32 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, - char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags) + char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags) /* stringarg: the point in the string at which to begin matching */ /* strend: pointer to null at end of string */ /* strbeg: real beginning of string */ @@ -3543,7 +3543,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* Be paranoid... */ if (prog == NULL) { - Perl_croak(aTHX_ "NULL regexp parameter"); + Perl_croak(aTHX_ "NULL regexp parameter"); } DEBUG_EXECUTE_r( @@ -3609,7 +3609,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, minlen = prog->minlen; if ((startpos + minlen) > strend || startpos < strbeg) { - DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Regex match can't succeed, so not even tried\n")); return 0; } @@ -3626,12 +3626,12 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if ((prog->extflags & RXf_USE_INTUIT) && !(flags & REXEC_CHECKED)) { - s = re_intuit_start(rx, sv, strbeg, startpos, strend, + s = re_intuit_start(rx, sv, strbeg, startpos, strend, flags, NULL); - if (!s) - return 0; + if (!s) + return 0; - if (prog->extflags & RXf_CHECK_ALL) { + if (prog->extflags & RXf_CHECK_ALL) { /* we can match based purely on the result of INTUIT. * Set up captures etc just for $& and $-[0] * (an intuit-only match wont have $1,$2,..) */ @@ -3662,7 +3662,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, strbeg, strend, sv, flags, utf8_target); - return 1; + return 1; } } @@ -3670,13 +3670,13 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ - "String too short [regexec_flags]...\n")); - goto phooey; + "String too short [regexec_flags]...\n")); + goto phooey; } /* Check validity of program. */ if (UCHARAT(progi->program) != REG_MAGIC) { - Perl_croak(aTHX_ "corrupted regexp program"); + Perl_croak(aTHX_ "corrupted regexp program"); } RXp_MATCH_TAINTED_off(prog); @@ -3766,12 +3766,12 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, SAVEFREEPV(swap); Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair); DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ - "rex=0x%" UVxf " saving offs: orig=0x%" UVxf " new=0x%" UVxf "\n", - 0, + "rex=0x%" UVxf " saving offs: orig=0x%" UVxf " new=0x%" UVxf "\n", + 0, PTR2UV(prog), - PTR2UV(swap), - PTR2UV(prog->offs) - )); + PTR2UV(swap), + PTR2UV(prog->offs) + )); } if (prog->recurse_locinput) @@ -3789,8 +3789,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) { char *end; - if (regtry(reginfo, &s)) - goto got_it; + if (regtry(reginfo, &s)) + goto got_it; if (!(prog->intflags & PREGf_ANCH_MBOL)) goto phooey; @@ -3831,72 +3831,72 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * (ganch-gofs); we already set startpos to this above; if intuit * moved us on from there, we can't possibly succeed */ assert(startpos == HOPBACKc(reginfo->ganch, prog->gofs)); - if (s == startpos && regtry(reginfo, &s)) - goto got_it; - goto phooey; + if (s == startpos && regtry(reginfo, &s)) + goto got_it; + goto phooey; } /* Messy cases: unanchored match. */ if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) { - /* we have /x+whatever/ */ - /* it must be a one character string (XXXX Except is_utf8_pat?) */ - char ch; + /* we have /x+whatever/ */ + /* it must be a one character string (XXXX Except is_utf8_pat?) */ + char ch; #ifdef DEBUGGING - int did_match = 0; + int did_match = 0; #endif - if (utf8_target) { + if (utf8_target) { if (! prog->anchored_utf8) { to_utf8_substr(prog); } ch = SvPVX_const(prog->anchored_utf8)[0]; - REXEC_FBC_UTF8_SCAN( - if (*s == ch) { - DEBUG_EXECUTE_r( did_match = 1 ); - if (regtry(reginfo, &s)) goto got_it; - s += UTF8_SAFE_SKIP(s, strend); - while (s < strend && *s == ch) - s += UTF8SKIP(s); - } - ); - - } - else { + REXEC_FBC_UTF8_SCAN( + if (*s == ch) { + DEBUG_EXECUTE_r( did_match = 1 ); + if (regtry(reginfo, &s)) goto got_it; + s += UTF8_SAFE_SKIP(s, strend); + while (s < strend && *s == ch) + s += UTF8SKIP(s); + } + ); + + } + else { if (! prog->anchored_substr) { if (! to_byte_substr(prog)) { NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey); } } ch = SvPVX_const(prog->anchored_substr)[0]; - REXEC_FBC_NON_UTF8_SCAN( - if (*s == ch) { - DEBUG_EXECUTE_r( did_match = 1 ); - if (regtry(reginfo, &s)) goto got_it; - s++; - while (s < strend && *s == ch) - s++; - } - ); - } - DEBUG_EXECUTE_r(if (!did_match) + REXEC_FBC_NON_UTF8_SCAN( + if (*s == ch) { + DEBUG_EXECUTE_r( did_match = 1 ); + if (regtry(reginfo, &s)) goto got_it; + s++; + while (s < strend && *s == ch) + s++; + } + ); + } + DEBUG_EXECUTE_r(if (!did_match) Perl_re_printf( aTHX_ "Did not find anchored character...\n") ); } else if (prog->anchored_substr != NULL - || prog->anchored_utf8 != NULL - || ((prog->float_substr != NULL || prog->float_utf8 != NULL) - && prog->float_max_offset < strend - s)) { - SV *must; - SSize_t back_max; - SSize_t back_min; - char *last; - char *last1; /* Last position checked before */ + || prog->anchored_utf8 != NULL + || ((prog->float_substr != NULL || prog->float_utf8 != NULL) + && prog->float_max_offset < strend - s)) { + SV *must; + SSize_t back_max; + SSize_t back_min; + char *last; + char *last1; /* Last position checked before */ #ifdef DEBUGGING - int did_match = 0; + int did_match = 0; #endif - if (prog->anchored_substr || prog->anchored_utf8) { - if (utf8_target) { + if (prog->anchored_substr || prog->anchored_utf8) { + if (utf8_target) { if (! prog->anchored_utf8) { to_utf8_substr(prog); } @@ -3910,9 +3910,9 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } must = prog->anchored_substr; } - back_max = back_min = prog->anchored_offset; - } else { - if (utf8_target) { + back_max = back_min = prog->anchored_offset; + } else { + if (utf8_target) { if (! prog->float_utf8) { to_utf8_substr(prog); } @@ -3926,104 +3926,104 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } must = prog->float_substr; } - back_max = prog->float_max_offset; - back_min = prog->float_min_offset; - } + back_max = prog->float_max_offset; + back_min = prog->float_min_offset; + } if (back_min<0) { - last = strend; - } else { + last = strend; + } else { last = HOP3c(strend, /* Cannot start after this */ - -(SSize_t)(CHR_SVLEN(must) - - (SvTAIL(must) != 0) + back_min), strbeg); - } - if (s > reginfo->strbeg) - last1 = HOPc(s, -1); - else - last1 = s - 1; /* bogus */ - - /* XXXX check_substr already used to find "s", can optimize if - check_substr==must. */ - dontbother = 0; - strend = HOPc(strend, -dontbother); - while ( (s <= last) && - (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend), - (unsigned char*)strend, must, - multiline ? FBMrf_MULTILINE : 0)) ) { - DEBUG_EXECUTE_r( did_match = 1 ); - if (HOPc(s, -back_max) > last1) { - last1 = HOPc(s, -back_min); - s = HOPc(s, -back_max); - } - else { - char * const t = (last1 >= reginfo->strbeg) + -(SSize_t)(CHR_SVLEN(must) + - (SvTAIL(must) != 0) + back_min), strbeg); + } + if (s > reginfo->strbeg) + last1 = HOPc(s, -1); + else + last1 = s - 1; /* bogus */ + + /* XXXX check_substr already used to find "s", can optimize if + check_substr==must. */ + dontbother = 0; + strend = HOPc(strend, -dontbother); + while ( (s <= last) && + (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend), + (unsigned char*)strend, must, + multiline ? FBMrf_MULTILINE : 0)) ) { + DEBUG_EXECUTE_r( did_match = 1 ); + if (HOPc(s, -back_max) > last1) { + last1 = HOPc(s, -back_min); + s = HOPc(s, -back_max); + } + else { + char * const t = (last1 >= reginfo->strbeg) ? HOPc(last1, 1) : last1 + 1; - last1 = HOPc(s, -back_min); - s = t; - } - if (utf8_target) { - while (s <= last1) { - if (regtry(reginfo, &s)) - goto got_it; + last1 = HOPc(s, -back_min); + s = t; + } + if (utf8_target) { + while (s <= last1) { + if (regtry(reginfo, &s)) + goto got_it; if (s >= last1) { s++; /* to break out of outer loop */ break; } s += UTF8SKIP(s); - } - } - else { - while (s <= last1) { - if (regtry(reginfo, &s)) - goto got_it; - s++; - } - } - } - DEBUG_EXECUTE_r(if (!did_match) { + } + } + else { + while (s <= last1) { + if (regtry(reginfo, &s)) + goto got_it; + s++; + } + } + } + DEBUG_EXECUTE_r(if (!did_match) { RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(must), RE_SV_DUMPLEN(must), 30); Perl_re_printf( aTHX_ "Did not find %s substr %s%s...\n", - ((must == prog->anchored_substr || must == prog->anchored_utf8) - ? "anchored" : "floating"), + ((must == prog->anchored_substr || must == prog->anchored_utf8) + ? "anchored" : "floating"), quoted, RE_SV_TAIL(must)); }); - goto phooey; + goto phooey; } else if ( (c = progi->regstclass) ) { - if (minlen) { - const OPCODE op = OP(progi->regstclass); - /* don't bother with what can't match */ - if (PL_regkind[op] != EXACT && PL_regkind[op] != TRIE) - strend = HOPc(strend, -(minlen - 1)); - } - DEBUG_EXECUTE_r({ - SV * const prop = sv_newmortal(); + if (minlen) { + const OPCODE op = OP(progi->regstclass); + /* don't bother with what can't match */ + if (PL_regkind[op] != EXACT && PL_regkind[op] != TRIE) + strend = HOPc(strend, -(minlen - 1)); + } + DEBUG_EXECUTE_r({ + SV * const prop = sv_newmortal(); regprop(prog, prop, c, reginfo, NULL); - { - RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1), - s,strend-s,PL_dump_re_max_len); + { + RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1), + s,strend-s,PL_dump_re_max_len); Perl_re_printf( aTHX_ - "Matching stclass %.*s against %s (%d bytes)\n", - (int)SvCUR(prop), SvPVX_const(prop), - quoted, (int)(strend - s)); - } - }); + "Matching stclass %.*s against %s (%d bytes)\n", + (int)SvCUR(prop), SvPVX_const(prop), + quoted, (int)(strend - s)); + } + }); if (find_byclass(prog, c, s, strend, reginfo)) - goto got_it; + goto got_it; DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Contradicts stclass... [regexec_flags]\n")); } else { - dontbother = 0; - if (prog->float_substr != NULL || prog->float_utf8 != NULL) { - /* Trim the end. */ - char *last= NULL; - SV* float_real; - STRLEN len; - const char *little; - - if (utf8_target) { + dontbother = 0; + if (prog->float_substr != NULL || prog->float_utf8 != NULL) { + /* Trim the end. */ + char *last= NULL; + SV* float_real; + STRLEN len; + const char *little; + + if (utf8_target) { if (! prog->float_utf8) { to_utf8_substr(prog); } @@ -4039,7 +4039,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } little = SvPV_const(float_real, len); - if (SvTAIL(float_real)) { + if (SvTAIL(float_real)) { /* This means that float_real contains an artificial \n on * the end due to the presence of something like this: * /foo$/ where we can match both "foo" and "foo\n" at the @@ -4049,89 +4049,89 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * have to watch out for cases where the string might be * smaller than the float_real or the float_real without * the \n. */ - char *checkpos= strend - len; - DEBUG_OPTIMISE_r( + char *checkpos= strend - len; + DEBUG_OPTIMISE_r( Perl_re_printf( aTHX_ - "%sChecking for float_real.%s\n", - PL_colors[4], PL_colors[5])); - if (checkpos + 1 < strbeg) { + "%sChecking for float_real.%s\n", + PL_colors[4], PL_colors[5])); + if (checkpos + 1 < strbeg) { /* can't match, even if we remove the trailing \n * string is too short to match */ - DEBUG_EXECUTE_r( + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ - "%sString shorter than required trailing substring, cannot match.%s\n", - PL_colors[4], PL_colors[5])); - goto phooey; - } else if (memEQ(checkpos + 1, little, len - 1)) { + "%sString shorter than required trailing substring, cannot match.%s\n", + PL_colors[4], PL_colors[5])); + goto phooey; + } else if (memEQ(checkpos + 1, little, len - 1)) { /* can match, the end of the string matches without the * "\n" */ - last = checkpos + 1; - } else if (checkpos < strbeg) { + last = checkpos + 1; + } else if (checkpos < strbeg) { /* cant match, string is too short when the "\n" is * included */ - DEBUG_EXECUTE_r( + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ - "%sString does not contain required trailing substring, cannot match.%s\n", - PL_colors[4], PL_colors[5])); - goto phooey; - } else if (!multiline) { + "%sString does not contain required trailing substring, cannot match.%s\n", + PL_colors[4], PL_colors[5])); + goto phooey; + } else if (!multiline) { /* non multiline match, so compare with the "\n" at the * end of the string */ - if (memEQ(checkpos, little, len)) { - last= checkpos; - } else { - DEBUG_EXECUTE_r( + if (memEQ(checkpos, little, len)) { + last= checkpos; + } else { + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ - "%sString does not contain required trailing substring, cannot match.%s\n", - PL_colors[4], PL_colors[5])); - goto phooey; - } - } else { + "%sString does not contain required trailing substring, cannot match.%s\n", + PL_colors[4], PL_colors[5])); + goto phooey; + } + } else { /* multiline match, so we have to search for a place * where the full string is located */ - goto find_last; - } - } else { - find_last: - if (len) - last = rninstr(s, strend, little, little + len); - else - last = strend; /* matching "$" */ - } - if (!last) { + goto find_last; + } + } else { + find_last: + if (len) + last = rninstr(s, strend, little, little + len); + else + last = strend; /* matching "$" */ + } + if (!last) { /* at one point this block contained a comment which was * probably incorrect, which said that this was a "should not * happen" case. Even if it was true when it was written I am * pretty sure it is not anymore, so I have removed the comment * and replaced it with this one. Yves */ - DEBUG_EXECUTE_r( + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ - "%sString does not contain required substring, cannot match.%s\n", + "%sString does not contain required substring, cannot match.%s\n", PL_colors[4], PL_colors[5] - )); - goto phooey; - } - dontbother = strend - last + prog->float_min_offset; - } - if (minlen && (dontbother < minlen)) - dontbother = minlen - 1; - strend -= dontbother; /* this one's always in bytes! */ - /* We don't know much -- general case. */ - if (utf8_target) { - for (;;) { - if (regtry(reginfo, &s)) - goto got_it; - if (s >= strend) - break; - s += UTF8SKIP(s); - }; - } - else { - do { - if (regtry(reginfo, &s)) - goto got_it; - } while (s++ < strend); - } + )); + goto phooey; + } + dontbother = strend - last + prog->float_min_offset; + } + if (minlen && (dontbother < minlen)) + dontbother = minlen - 1; + strend -= dontbother; /* this one's always in bytes! */ + /* We don't know much -- general case. */ + if (utf8_target) { + for (;;) { + if (regtry(reginfo, &s)) + goto got_it; + if (s >= strend) + break; + s += UTF8SKIP(s); + }; + } + else { + do { + if (regtry(reginfo, &s)) + goto got_it; + } while (s++ < strend); + } } /* Failure. */ @@ -4169,7 +4169,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, phooey: DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch failed%s\n", - PL_colors[4], PL_colors[5])); + PL_colors[4], PL_colors[5])); if (swap) { /* we failed :-( roll it back. @@ -4178,12 +4178,12 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * data to the new offs buffer */ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ - "rex=0x%" UVxf " rolling back offs: 0x%" UVxf " will be freed; restoring data to =0x%" UVxf "\n", - 0, + "rex=0x%" UVxf " rolling back offs: 0x%" UVxf " will be freed; restoring data to =0x%" UVxf "\n", + 0, PTR2UV(prog), - PTR2UV(prog->offs), - PTR2UV(swap) - )); + PTR2UV(prog->offs), + PTR2UV(swap) + )); Copy(swap, prog->offs, prog->nparens + 1, regexp_paren_pair); } @@ -4202,9 +4202,9 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * Do inc before dec, in case old and new rex are the same */ #define SET_reg_curpm(Re2) \ if (reginfo->info_aux_eval) { \ - (void)ReREFCNT_inc(Re2); \ - ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \ - PM_SETRE((PL_reg_curpm), (Re2)); \ + (void)ReREFCNT_inc(Re2); \ + ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \ + PM_SETRE((PL_reg_curpm), (Re2)); \ } @@ -4255,20 +4255,20 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) * places it is called, and related regcp() routines. - Yves */ #if 1 if (prog->nparens) { - regexp_paren_pair *pp = prog->offs; - I32 i; - for (i = prog->nparens; i > (I32)prog->lastparen; i--) { - ++pp; - pp->start = -1; - pp->end = -1; - } + regexp_paren_pair *pp = prog->offs; + I32 i; + for (i = prog->nparens; i > (I32)prog->lastparen; i--) { + ++pp; + pp->start = -1; + pp->end = -1; + } } #endif REGCP_SET(lastcp); result = regmatch(reginfo, *startposp, progi->program + 1); if (result != -1) { - prog->offs[0].end = result; - return 1; + prog->offs[0].end = result; + return 1; } if (reginfo->cutpoint) *startposp= reginfo->cutpoint; @@ -4305,10 +4305,10 @@ S_push_slab(pTHX) { regmatch_slab *s = PL_regmatch_slab->next; if (!s) { - Newx(s, 1, regmatch_slab); - s->prev = PL_regmatch_slab; - s->next = NULL; - PL_regmatch_slab->next = s; + Newx(s, 1, regmatch_slab); + s->prev = PL_regmatch_slab; + s->next = NULL; + PL_regmatch_slab->next = s; } PL_regmatch_slab = s; return SLAB_FIRST(s); @@ -4335,7 +4335,7 @@ S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target, Perl_re_printf( aTHX_ "%s%s REx%s %s against %s\n", - PL_colors[4], blurb, PL_colors[5], s0, s1); + PL_colors[4], blurb, PL_colors[5], s0, s1); if (utf8_target||utf8_pat) Perl_re_printf( aTHX_ "UTF-8 %s%s%s...\n", @@ -4366,45 +4366,45 @@ S_dump_exec_pos(pTHX_ const char *locinput, We assume that pref0_len <= pref_len, otherwise we decrease pref0_len. */ int pref_len = (locinput - loc_bostr) > (5 + taill) - l - ? (5 + taill) - l : locinput - loc_bostr; + ? (5 + taill) - l : locinput - loc_bostr; int pref0_len; PERL_ARGS_ASSERT_DUMP_EXEC_POS; while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) - pref_len++; + pref_len++; pref0_len = pref_len - (locinput - loc_reg_starttry); if (l + pref_len < (5 + taill) && l < loc_regeol - locinput) - l = ( loc_regeol - locinput > (5 + taill) - pref_len - ? (5 + taill) - pref_len : loc_regeol - locinput); + l = ( loc_regeol - locinput > (5 + taill) - pref_len + ? (5 + taill) - pref_len : loc_regeol - locinput); while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l))) - l--; + l--; if (pref0_len < 0) - pref0_len = 0; + pref0_len = 0; if (pref0_len > pref_len) - pref0_len = pref_len; + pref0_len = pref_len; { - const int is_uni = utf8_target ? 1 : 0; + const int is_uni = utf8_target ? 1 : 0; - RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0), - (locinput - pref_len),pref0_len, PL_dump_re_max_len, 4, 5); + RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0), + (locinput - pref_len),pref0_len, PL_dump_re_max_len, 4, 5); - RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1), - (locinput - pref_len + pref0_len), - pref_len - pref0_len, PL_dump_re_max_len, 2, 3); + RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1), + (locinput - pref_len + pref0_len), + pref_len - pref0_len, PL_dump_re_max_len, 2, 3); - RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2), - locinput, loc_regeol - locinput, 10, 0, 1); + RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2), + locinput, loc_regeol - locinput, 10, 0, 1); - const STRLEN tlen=len0+len1+len2; + const STRLEN tlen=len0+len1+len2; Perl_re_printf( aTHX_ "%4" IVdf " <%.*s%.*s%s%.*s>%*s|%4u| ", - (IV)(locinput - loc_bostr), - len0, s0, - len1, s1, - (docolor ? "" : "> <"), - len2, s2, - (int)(tlen > 19 ? 0 : 19 - tlen), + (IV)(locinput - loc_bostr), + len0, s0, + len1, s1, + (docolor ? "" : "> <"), + len2, s2, + (int)(tlen > 19 ? 0 : 19 - tlen), "", depth); } @@ -6190,22 +6190,22 @@ Here's a concrete example of a (vastly oversimplified) IFMATCH #define ST st->u.ifmatch case IFMATCH: // we are executing the IFMATCH op, (?=A)B - ST.foo = ...; // some state we wish to save - ... - // push a yes backtrack state with a resume value of - // IFMATCH_A/IFMATCH_A_fail, then continue execution at the - // first node of A: - PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput); - // NOTREACHED + ST.foo = ...; // some state we wish to save + ... + // push a yes backtrack state with a resume value of + // IFMATCH_A/IFMATCH_A_fail, then continue execution at the + // first node of A: + PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput); + // NOTREACHED case IFMATCH_A: // we have successfully executed A; now continue with B - next = B; - bar = ST.foo; // do something with the preserved value - break; + next = B; + bar = ST.foo; // do something with the preserved value + break; case IFMATCH_A_fail: // A failed, so the assertion failed - ...; // do some housekeeping, then ... - sayNO; // propagate the failure + ...; // do some housekeeping, then ... + sayNO; // propagate the failure #undef ST @@ -6217,23 +6217,23 @@ approach, the code above is equivalent to: case IFMATCH: // we are executing the IFMATCH op, (?=A)B { - int foo = ... - ... - if (regmatch(A)) { - next = B; - bar = foo; - break; - } - ...; // do some housekeeping, then ... - sayNO; // propagate the failure + int foo = ... + ... + if (regmatch(A)) { + next = B; + bar = foo; + break; + } + ...; // do some housekeeping, then ... + sayNO; // propagate the failure } The topmost backtrack state, pointed to by st, is usually free. If you want to claim it, populate any ST.foo fields in it with values you wish to save, then do one of - PUSH_STATE_GOTO(resume_state, node, newinput, new_eol); - PUSH_YES_STATE_GOTO(resume_state, node, newinput, new_eol); + PUSH_STATE_GOTO(resume_state, node, newinput, new_eol); + PUSH_YES_STATE_GOTO(resume_state, node, newinput, new_eol); which sets that backtrack state's resume value to 'resume_state', pushes a new free entry to the top of the backtrack stack, then goes to 'node'. @@ -6305,7 +6305,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ? 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH; regmatch_state *yes_state = NULL; /* state to pop to on success of - subpattern */ + subpattern */ /* mark_state piggy backs on the yes_state logic so that when we unwind the stack on success we can update the mark_state as we go */ regmatch_state *mark_state = NULL; /* last mark state we have seen */ @@ -6329,13 +6329,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) bool sw = 0; /* the condition value in (?(cond)a|b) */ bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */ int logical = 0; /* the following EVAL is: - 0: (?{...}) - 1: (?(?{...})X|Y) - 2: (??{...}) - or the following IFMATCH/UNLESSM is: - false: plain (?=foo) - true: used as a condition: (?(?=foo)) - */ + 0: (?{...}) + 1: (?(?{...})X|Y) + 2: (??{...}) + or the following IFMATCH/UNLESSM is: + false: plain (?=foo) + true: used as a condition: (?(?=foo)) + */ PAD* last_pad = NULL; dMULTICALL; U8 gimme = G_SCALAR; @@ -6381,10 +6381,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) })); while (scan != NULL) { - next = scan + NEXT_OFF(scan); - if (next == scan) - next = NULL; - state_num = OP(scan); + next = scan + NEXT_OFF(scan); + if (next == scan) + next = NULL; + state_num = OP(scan); reenter_switch: DEBUG_EXECUTE_r( @@ -6409,67 +6409,67 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SET_nextchr; assert(nextbyte < 256 && (nextbyte >= 0 || nextbyte == NEXTCHR_EOS)); - switch (state_num) { - case SBOL: /* /^../ and /\A../ */ - if (locinput == reginfo->strbeg) - break; - sayNO; - - case MBOL: /* /^../m */ - if (locinput == reginfo->strbeg || - (!NEXTCHR_IS_EOS && locinput[-1] == '\n')) - { - break; - } - sayNO; - - case GPOS: /* \G */ - if (locinput == reginfo->ganch) - break; - sayNO; - - case KEEPS: /* \K */ - /* update the startpoint */ - st->u.keeper.val = rex->offs[0].start; - rex->offs[0].start = locinput - reginfo->strbeg; - PUSH_STATE_GOTO(KEEPS_next, next, locinput, loceol, + switch (state_num) { + case SBOL: /* /^../ and /\A../ */ + if (locinput == reginfo->strbeg) + break; + sayNO; + + case MBOL: /* /^../m */ + if (locinput == reginfo->strbeg || + (!NEXTCHR_IS_EOS && locinput[-1] == '\n')) + { + break; + } + sayNO; + + case GPOS: /* \G */ + if (locinput == reginfo->ganch) + break; + sayNO; + + case KEEPS: /* \K */ + /* update the startpoint */ + st->u.keeper.val = rex->offs[0].start; + rex->offs[0].start = locinput - reginfo->strbeg; + PUSH_STATE_GOTO(KEEPS_next, next, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - - case KEEPS_next_fail: - /* rollback the start point change */ - rex->offs[0].start = st->u.keeper.val; - sayNO_SILENT; - NOT_REACHED; /* NOTREACHED */ - - case MEOL: /* /..$/m */ - if (!NEXTCHR_IS_EOS && nextbyte != '\n') - sayNO; - break; - - case SEOL: /* /..$/ */ - if (!NEXTCHR_IS_EOS && nextbyte != '\n') - sayNO; - if (reginfo->strend - locinput > 1) - sayNO; - break; - - case EOS: /* \z */ - if (!NEXTCHR_IS_EOS) - sayNO; - break; - - case SANY: /* /./s */ - if (NEXTCHR_IS_EOS || locinput >= loceol) - sayNO; + NOT_REACHED; /* NOTREACHED */ + + case KEEPS_next_fail: + /* rollback the start point change */ + rex->offs[0].start = st->u.keeper.val; + sayNO_SILENT; + NOT_REACHED; /* NOTREACHED */ + + case MEOL: /* /..$/m */ + if (!NEXTCHR_IS_EOS && nextbyte != '\n') + sayNO; + break; + + case SEOL: /* /..$/ */ + if (!NEXTCHR_IS_EOS && nextbyte != '\n') + sayNO; + if (reginfo->strend - locinput > 1) + sayNO; + break; + + case EOS: /* \z */ + if (!NEXTCHR_IS_EOS) + sayNO; + break; + + case SANY: /* /./s */ + if (NEXTCHR_IS_EOS || locinput >= loceol) + sayNO; goto increment_locinput; - case REG_ANY: /* /./ */ - if ( NEXTCHR_IS_EOS + case REG_ANY: /* /./ */ + if ( NEXTCHR_IS_EOS || locinput >= loceol || nextbyte == '\n') { - sayNO; + sayNO; } goto increment_locinput; @@ -6492,59 +6492,59 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) NOT_REACHED; /* NOTREACHED */ } /* FALLTHROUGH */ - case TRIE: /* (ab|cd) */ - /* the basic plan of execution of the trie is: - * At the beginning, run though all the states, and - * find the longest-matching word. Also remember the position - * of the shortest matching word. For example, this pattern: - * 1 2 3 4 5 - * ab|a|x|abcd|abc - * when matched against the string "abcde", will generate - * accept states for all words except 3, with the longest - * matching word being 4, and the shortest being 2 (with - * the position being after char 1 of the string). - * - * Then for each matching word, in word order (i.e. 1,2,4,5), - * we run the remainder of the pattern; on each try setting - * the current position to the character following the word, - * returning to try the next word on failure. - * - * We avoid having to build a list of words at runtime by - * using a compile-time structure, wordinfo[].prev, which - * gives, for each word, the previous accepting word (if any). - * In the case above it would contain the mappings 1->2, 2->0, - * 3->0, 4->5, 5->1. We can use this table to generate, from - * the longest word (4 above), a list of all words, by - * following the list of prev pointers; this gives us the - * unordered list 4,5,1,2. Then given the current word we have - * just tried, we can go through the list and find the - * next-biggest word to try (so if we just failed on word 2, - * the next in the list is 4). - * - * Since at runtime we don't record the matching position in - * the string for each word, we have to work that out for - * each word we're about to process. The wordinfo table holds - * the character length of each word; given that we recorded - * at the start: the position of the shortest word and its - * length in chars, we just need to move the pointer the - * difference between the two char lengths. Depending on - * Unicode status and folding, that's cheap or expensive. - * - * This algorithm is optimised for the case where are only a - * small number of accept states, i.e. 0,1, or maybe 2. - * With lots of accepts states, and having to try all of them, - * it becomes quadratic on number of accept states to find all - * the next words. - */ - - { + case TRIE: /* (ab|cd) */ + /* the basic plan of execution of the trie is: + * At the beginning, run though all the states, and + * find the longest-matching word. Also remember the position + * of the shortest matching word. For example, this pattern: + * 1 2 3 4 5 + * ab|a|x|abcd|abc + * when matched against the string "abcde", will generate + * accept states for all words except 3, with the longest + * matching word being 4, and the shortest being 2 (with + * the position being after char 1 of the string). + * + * Then for each matching word, in word order (i.e. 1,2,4,5), + * we run the remainder of the pattern; on each try setting + * the current position to the character following the word, + * returning to try the next word on failure. + * + * We avoid having to build a list of words at runtime by + * using a compile-time structure, wordinfo[].prev, which + * gives, for each word, the previous accepting word (if any). + * In the case above it would contain the mappings 1->2, 2->0, + * 3->0, 4->5, 5->1. We can use this table to generate, from + * the longest word (4 above), a list of all words, by + * following the list of prev pointers; this gives us the + * unordered list 4,5,1,2. Then given the current word we have + * just tried, we can go through the list and find the + * next-biggest word to try (so if we just failed on word 2, + * the next in the list is 4). + * + * Since at runtime we don't record the matching position in + * the string for each word, we have to work that out for + * each word we're about to process. The wordinfo table holds + * the character length of each word; given that we recorded + * at the start: the position of the shortest word and its + * length in chars, we just need to move the pointer the + * difference between the two char lengths. Depending on + * Unicode status and folding, that's cheap or expensive. + * + * This algorithm is optimised for the case where are only a + * small number of accept states, i.e. 0,1, or maybe 2. + * With lots of accepts states, and having to try all of them, + * it becomes quadratic on number of accept states to find all + * the next words. + */ + + { /* what type of TRIE am I? (utf8 makes this contextual) */ DECL_TRIE_TYPE(scan); /* what trie are we using right now */ - reg_trie_data * const trie - = (reg_trie_data*)rexi->data->data[ ARG( scan ) ]; - HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]); + reg_trie_data * const trie + = (reg_trie_data*)rexi->data->data[ ARG( scan ) ]; + HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]); U32 state = trie->startstate; if (scan->flags == EXACTL || scan->flags == EXACTFLU8) { @@ -6566,134 +6566,134 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) || locinput >= loceol || ! TRIE_BITMAP_TEST(trie, nextbyte))) { - if (trie->states[ state ].wordnum) { - DEBUG_EXECUTE_r( + if (trie->states[ state ].wordnum) { + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "%sTRIE: matched empty string...%s\n", depth, PL_colors[4], PL_colors[5]) ); - if (!trie->jump) - break; - } else { - DEBUG_EXECUTE_r( + if (!trie->jump) + break; + } else { + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "%sTRIE: failed to match trie start class...%s\n", depth, PL_colors[4], PL_colors[5]) ); - sayNO_SILENT; - } + sayNO_SILENT; + } } { - U8 *uc = ( U8* )locinput; - - STRLEN len = 0; - STRLEN foldlen = 0; - U8 *uscan = (U8*)NULL; - U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; - U32 charcount = 0; /* how many input chars we have matched */ - U32 accepted = 0; /* have we seen any accepting states? */ - - ST.jump = trie->jump; - ST.me = scan; - ST.firstpos = NULL; - ST.longfold = FALSE; /* char longer if folded => it's harder */ - ST.nextword = 0; - - /* fully traverse the TRIE; note the position of the - shortest accept state and the wordnum of the longest - accept state */ - - while ( state && uc <= (U8*)(loceol) ) { + U8 *uc = ( U8* )locinput; + + STRLEN len = 0; + STRLEN foldlen = 0; + U8 *uscan = (U8*)NULL; + U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; + U32 charcount = 0; /* how many input chars we have matched */ + U32 accepted = 0; /* have we seen any accepting states? */ + + ST.jump = trie->jump; + ST.me = scan; + ST.firstpos = NULL; + ST.longfold = FALSE; /* char longer if folded => it's harder */ + ST.nextword = 0; + + /* fully traverse the TRIE; note the position of the + shortest accept state and the wordnum of the longest + accept state */ + + while ( state && uc <= (U8*)(loceol) ) { U32 base = trie->states[ state ].trans.base; UV uvc = 0; U16 charid = 0; - U16 wordnum; + U16 wordnum; wordnum = trie->states[ state ].wordnum; - if (wordnum) { /* it's an accept state */ - if (!accepted) { - accepted = 1; - /* record first match position */ - if (ST.longfold) { - ST.firstpos = (U8*)locinput; - ST.firstchars = 0; - } - else { - ST.firstpos = uc; - ST.firstchars = charcount; - } - } - if (!ST.nextword || wordnum < ST.nextword) - ST.nextword = wordnum; - ST.topword = wordnum; - } - - DEBUG_TRIE_EXECUTE_r({ + if (wordnum) { /* it's an accept state */ + if (!accepted) { + accepted = 1; + /* record first match position */ + if (ST.longfold) { + ST.firstpos = (U8*)locinput; + ST.firstchars = 0; + } + else { + ST.firstpos = uc; + ST.firstchars = charcount; + } + } + if (!ST.nextword || wordnum < ST.nextword) + ST.nextword = wordnum; + ST.topword = wordnum; + } + + DEBUG_TRIE_EXECUTE_r({ DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth ); /* HERE */ PerlIO_printf( Perl_debug_log, "%*s%sTRIE: State: %4" UVxf " Accepted: %c ", INDENT_CHARS(depth), "", PL_colors[4], - (UV)state, (accepted ? 'Y' : 'N')); - }); + (UV)state, (accepted ? 'Y' : 'N')); + }); - /* read a char and goto next state */ - if ( base && (foldlen || uc < (U8*)(loceol))) { - I32 offset; - REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, + /* read a char and goto next state */ + if ( base && (foldlen || uc < (U8*)(loceol))) { + I32 offset; + REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, (U8 *) loceol, uscan, len, uvc, charid, foldlen, foldbuf, uniflags); - charcount++; - if (foldlen>0) - ST.longfold = TRUE; - if (charid && - ( ((offset = - base + charid - 1 - trie->uniquecharcount)) >= 0) - - && ((U32)offset < trie->lasttrans) - && trie->trans[offset].check == state) - { - state = trie->trans[offset].next; - } - else { - state = 0; - } - uc += len; - - } - else { - state = 0; - } - DEBUG_TRIE_EXECUTE_r( + charcount++; + if (foldlen>0) + ST.longfold = TRUE; + if (charid && + ( ((offset = + base + charid - 1 - trie->uniquecharcount)) >= 0) + + && ((U32)offset < trie->lasttrans) + && trie->trans[offset].check == state) + { + state = trie->trans[offset].next; + } + else { + state = 0; + } + uc += len; + + } + else { + state = 0; + } + DEBUG_TRIE_EXECUTE_r( Perl_re_printf( aTHX_ - "TRIE: Charid:%3x CP:%4" UVxf " After State: %4" UVxf "%s\n", - charid, uvc, (UV)state, PL_colors[5] ); - ); - } - if (!accepted) - sayNO; - - /* calculate total number of accept states */ - { - U16 w = ST.topword; - accepted = 0; - while (w) { - w = trie->wordinfo[w].prev; - accepted++; - } - ST.accepted = accepted; - } - - DEBUG_EXECUTE_r( + "TRIE: Charid:%3x CP:%4" UVxf " After State: %4" UVxf "%s\n", + charid, uvc, (UV)state, PL_colors[5] ); + ); + } + if (!accepted) + sayNO; + + /* calculate total number of accept states */ + { + U16 w = ST.topword; + accepted = 0; + while (w) { + w = trie->wordinfo[w].prev; + accepted++; + } + ST.accepted = accepted; + } + + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "%sTRIE: got %" IVdf " possible matches%s\n", depth, - PL_colors[4], (IV)ST.accepted, PL_colors[5] ); - ); - goto trie_first_try; /* jump into the fail handler */ - }} - NOT_REACHED; /* NOTREACHED */ + PL_colors[4], (IV)ST.accepted, PL_colors[5] ); + ); + goto trie_first_try; /* jump into the fail handler */ + }} + NOT_REACHED; /* NOTREACHED */ - case TRIE_next_fail: /* we failed - try next alternative */ + case TRIE_next_fail: /* we failed - try next alternative */ { U8 *uc; if ( ST.jump ) { @@ -6704,30 +6704,30 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * rest of the branch */ REGCP_UNWIND(ST.cp); UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); - } - if (!--ST.accepted) { - DEBUG_EXECUTE_r({ + } + if (!--ST.accepted) { + DEBUG_EXECUTE_r({ Perl_re_exec_indentf( aTHX_ "%sTRIE failed...%s\n", depth, - PL_colors[4], - PL_colors[5] ); - }); - sayNO_SILENT; - } - { - /* Find next-highest word to process. Note that this code - * is O(N^2) per trie run (O(N) per branch), so keep tight */ - U16 min = 0; - U16 word; - U16 const nextword = ST.nextword; - reg_trie_wordinfo * const wordinfo - = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo; - for (word=ST.topword; word; word=wordinfo[word].prev) { - if (word > nextword && (!min || word < min)) - min = word; - } - ST.nextword = min; - } + PL_colors[4], + PL_colors[5] ); + }); + sayNO_SILENT; + } + { + /* Find next-highest word to process. Note that this code + * is O(N^2) per trie run (O(N) per branch), so keep tight */ + U16 min = 0; + U16 word; + U16 const nextword = ST.nextword; + reg_trie_wordinfo * const wordinfo + = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo; + for (word=ST.topword; word; word=wordinfo[word].prev) { + if (word > nextword && (!min || word < min)) + min = word; + } + ST.nextword = min; + } trie_first_try: if (do_cutgroup) { @@ -6738,121 +6738,121 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if ( ST.jump ) { ST.lastparen = rex->lastparen; ST.lastcloseparen = rex->lastcloseparen; - REGCP_SET(ST.cp); - } - - /* find start char of end of current word */ - { - U32 chars; /* how many chars to skip */ - reg_trie_data * const trie - = (reg_trie_data*)rexi->data->data[ARG(ST.me)]; - - assert((trie->wordinfo[ST.nextword].len - trie->prefixlen) - >= ST.firstchars); - chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen) - - ST.firstchars; - uc = ST.firstpos; - - if (ST.longfold) { - /* the hard option - fold each char in turn and find - * its folded length (which may be different */ - U8 foldbuf[UTF8_MAXBYTES_CASE + 1]; - STRLEN foldlen; - STRLEN len; - UV uvc; - U8 *uscan; - - while (chars) { - if (utf8_target) { + REGCP_SET(ST.cp); + } + + /* find start char of end of current word */ + { + U32 chars; /* how many chars to skip */ + reg_trie_data * const trie + = (reg_trie_data*)rexi->data->data[ARG(ST.me)]; + + assert((trie->wordinfo[ST.nextword].len - trie->prefixlen) + >= ST.firstchars); + chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen) + - ST.firstchars; + uc = ST.firstpos; + + if (ST.longfold) { + /* the hard option - fold each char in turn and find + * its folded length (which may be different */ + U8 foldbuf[UTF8_MAXBYTES_CASE + 1]; + STRLEN foldlen; + STRLEN len; + UV uvc; + U8 *uscan; + + while (chars) { + if (utf8_target) { /* XXX This assumes the length is well-formed, as * does the UTF8SKIP below */ - uvc = utf8n_to_uvchr((U8*)uc, UTF8_MAXLEN, &len, - uniflags); - uc += len; - } - else { - uvc = *uc; - uc++; - } - uvc = to_uni_fold(uvc, foldbuf, &foldlen); - uscan = foldbuf; - while (foldlen) { - if (!--chars) - break; - uvc = utf8n_to_uvchr(uscan, foldlen, &len, + uvc = utf8n_to_uvchr((U8*)uc, UTF8_MAXLEN, &len, + uniflags); + uc += len; + } + else { + uvc = *uc; + uc++; + } + uvc = to_uni_fold(uvc, foldbuf, &foldlen); + uscan = foldbuf; + while (foldlen) { + if (!--chars) + break; + uvc = utf8n_to_uvchr(uscan, foldlen, &len, uniflags); - uscan += len; - foldlen -= len; - } - } - } - else { - if (utf8_target) - while (chars--) - uc += UTF8SKIP(uc); - else - uc += chars; - } - } - - scan = ST.me + ((ST.jump && ST.jump[ST.nextword]) - ? ST.jump[ST.nextword] - : NEXT_OFF(ST.me)); - - DEBUG_EXECUTE_r({ + uscan += len; + foldlen -= len; + } + } + } + else { + if (utf8_target) + while (chars--) + uc += UTF8SKIP(uc); + else + uc += chars; + } + } + + scan = ST.me + ((ST.jump && ST.jump[ST.nextword]) + ? ST.jump[ST.nextword] + : NEXT_OFF(ST.me)); + + DEBUG_EXECUTE_r({ Perl_re_exec_indentf( aTHX_ "%sTRIE matched word #%d, continuing%s\n", depth, - PL_colors[4], - ST.nextword, - PL_colors[5] - ); - }); - - if ( ST.accepted > 1 || has_cutgroup || ST.jump ) { - PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc, loceol, + PL_colors[4], + ST.nextword, + PL_colors[5] + ); + }); + + if ( ST.accepted > 1 || has_cutgroup || ST.jump ) { + PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } - /* only one choice left - just continue */ - DEBUG_EXECUTE_r({ - AV *const trie_words - = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]); - SV ** const tmp = trie_words + NOT_REACHED; /* NOTREACHED */ + } + /* only one choice left - just continue */ + DEBUG_EXECUTE_r({ + AV *const trie_words + = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]); + SV ** const tmp = trie_words ? av_fetch(trie_words, ST.nextword - 1, 0) : NULL; - SV *sv= tmp ? sv_newmortal() : NULL; + SV *sv= tmp ? sv_newmortal() : NULL; Perl_re_exec_indentf( aTHX_ "%sTRIE: only one match left, short-circuiting: #%d <%s>%s\n", depth, PL_colors[4], - ST.nextword, - tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII - ) - : "not compiled under -Dr", - PL_colors[5] ); - }); - - locinput = (char*)uc; - continue; /* execute rest of RE */ + ST.nextword, + tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII + ) + : "not compiled under -Dr", + PL_colors[5] ); + }); + + locinput = (char*)uc; + continue; /* execute rest of RE */ /* NOTREACHED */ } #undef ST - case LEXACT_REQ8: + case LEXACT_REQ8: if (! utf8_target) { sayNO; } /* FALLTHROUGH */ - case LEXACT: + case LEXACT: { - char *s; + char *s; - s = STRINGl(scan); - ln = STR_LENl(scan); + s = STRINGl(scan); + ln = STR_LENl(scan); goto join_short_long_exact; - case EXACTL: /* /abc/l */ + case EXACTL: /* /abc/l */ _CHECK_AND_WARN_PROBLEMATIC_LOCALE; /* Complete checking would involve going through every character @@ -6865,24 +6865,24 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend); } goto do_exact; - case EXACT_REQ8: + case EXACT_REQ8: if (! utf8_target) { sayNO; } /* FALLTHROUGH */ - case EXACT: /* /abc/ */ + case EXACT: /* /abc/ */ do_exact: - s = STRINGs(scan); - ln = STR_LENs(scan); + s = STRINGs(scan); + ln = STR_LENs(scan); join_short_long_exact: - if (utf8_target != is_utf8_pat) { - /* The target and the pattern have differing utf8ness. */ - char *l = locinput; - const char * const e = s + ln; + if (utf8_target != is_utf8_pat) { + /* The target and the pattern have differing utf8ness. */ + char *l = locinput; + const char * const e = s + ln; - if (utf8_target) { + if (utf8_target) { /* The target is utf8, the pattern is not utf8. * Above-Latin1 code points can't match the pattern; * invariants match exactly, and the other Latin1 ones need @@ -6892,14 +6892,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * tests by just assuming that if the first bytes match, it * is an invariant, but there are tests in the test suite * dealing with (??{...}) which violate this) */ - while (s < e) { - if ( l >= loceol + while (s < e) { + if ( l >= loceol || UTF8_IS_ABOVE_LATIN1(* (U8*) l)) { sayNO; } if (UTF8_IS_INVARIANT(*(U8*)l)) { - if (*l != *s) { + if (*l != *s) { sayNO; } l++; @@ -6911,19 +6911,19 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } l += 2; } - s++; - } - } - else { - /* The target is not utf8, the pattern is utf8. */ - while (s < e) { + s++; + } + } + else { + /* The target is not utf8, the pattern is utf8. */ + while (s < e) { if ( l >= loceol || UTF8_IS_ABOVE_LATIN1(* (U8*) s)) { sayNO; } if (UTF8_IS_INVARIANT(*(U8*)s)) { - if (*s != *l) { + if (*s != *l) { sayNO; } s++; @@ -6935,11 +6935,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } s += 2; } - l++; - } - } - locinput = l; - } + l++; + } + } + locinput = l; + } else { /* The target and the pattern have the same utf8ness. */ /* Inline the first character, for speed. */ @@ -6951,21 +6951,21 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } locinput += ln; } - break; - } + break; + } - case EXACTFL: /* /abc/il */ + case EXACTFL: /* /abc/il */ { - re_fold_t folder; - const U8 * fold_array; - const char * s; - U32 fold_utf8_flags; + re_fold_t folder; + const U8 * fold_array; + const char * s; + U32 fold_utf8_flags; _CHECK_AND_WARN_PROBLEMATIC_LOCALE; folder = foldEQ_locale; fold_array = PL_fold_locale; - fold_utf8_flags = FOLDEQ_LOCALE; - goto do_exactf; + fold_utf8_flags = FOLDEQ_LOCALE; + goto do_exactf; case EXACTFLU8: /* /abc/il; but all 'abc' are above 255, so is effectively /u; hence to match, target @@ -6975,40 +6975,40 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } fold_utf8_flags = FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED | FOLDEQ_S2_FOLDS_SANE; - folder = foldEQ_latin1_s2_folded; - fold_array = PL_fold_latin1; - goto do_exactf; + folder = foldEQ_latin1_s2_folded; + fold_array = PL_fold_latin1; + goto do_exactf; case EXACTFU_REQ8: /* /abc/iu with something in /abc/ > 255 */ if (! utf8_target) { sayNO; } - assert(is_utf8_pat); - fold_utf8_flags = FOLDEQ_S2_ALREADY_FOLDED; - goto do_exactf; + assert(is_utf8_pat); + fold_utf8_flags = FOLDEQ_S2_ALREADY_FOLDED; + goto do_exactf; case EXACTFUP: /* /foo/iu, and something is problematic in 'foo' so can't take shortcuts. */ assert(! is_utf8_pat); folder = foldEQ_latin1; - fold_array = PL_fold_latin1; - fold_utf8_flags = 0; - goto do_exactf; + fold_array = PL_fold_latin1; + fold_utf8_flags = 0; + goto do_exactf; - case EXACTFU: /* /abc/iu */ + case EXACTFU: /* /abc/iu */ folder = foldEQ_latin1_s2_folded; - fold_array = PL_fold_latin1; - fold_utf8_flags = FOLDEQ_S2_ALREADY_FOLDED; - goto do_exactf; + fold_array = PL_fold_latin1; + fold_utf8_flags = FOLDEQ_S2_ALREADY_FOLDED; + goto do_exactf; case EXACTFAA_NO_TRIE: /* This node only generated for non-utf8 patterns */ assert(! is_utf8_pat); /* FALLTHROUGH */ - case EXACTFAA: /* /abc/iaa */ + case EXACTFAA: /* /abc/iaa */ folder = foldEQ_latin1_s2_folded; - fold_array = PL_fold_latin1; - fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII; + fold_array = PL_fold_latin1; + fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII; if (is_utf8_pat || ! utf8_target) { /* The possible presence of a MICRO SIGN in the pattern forbids @@ -7017,59 +7017,59 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) fold_utf8_flags |= FOLDEQ_S2_ALREADY_FOLDED |FOLDEQ_S2_FOLDS_SANE; } - goto do_exactf; + goto do_exactf; case EXACTF: /* /abc/i This node only generated for non-utf8 patterns */ assert(! is_utf8_pat); - folder = foldEQ; - fold_array = PL_fold; - fold_utf8_flags = 0; + folder = foldEQ; + fold_array = PL_fold; + fold_utf8_flags = 0; - do_exactf: - s = STRINGs(scan); - ln = STR_LENs(scan); + do_exactf: + s = STRINGs(scan); + ln = STR_LENs(scan); - if ( utf8_target + if ( utf8_target || is_utf8_pat || state_num == EXACTFUP || (state_num == EXACTFL && IN_UTF8_CTYPE_LOCALE)) { - /* Either target or the pattern are utf8, or has the issue where - * the fold lengths may differ. */ - const char * const l = locinput; - char *e = loceol; + /* Either target or the pattern are utf8, or has the issue where + * the fold lengths may differ. */ + const char * const l = locinput; + char *e = loceol; - if (! foldEQ_utf8_flags(l, &e, 0, utf8_target, + if (! foldEQ_utf8_flags(l, &e, 0, utf8_target, s, 0, ln, is_utf8_pat,fold_utf8_flags)) - { - sayNO; - } - locinput = e; - break; - } - - /* Neither the target nor the pattern are utf8 */ - if (UCHARAT(s) != nextbyte + { + sayNO; + } + locinput = e; + break; + } + + /* Neither the target nor the pattern are utf8 */ + if (UCHARAT(s) != nextbyte && !NEXTCHR_IS_EOS - && UCHARAT(s) != fold_array[nextbyte]) - { - sayNO; - } - if (loceol - locinput < ln) - sayNO; - if (ln > 1 && ! folder(locinput, s, ln)) - sayNO; - locinput += ln; - break; - } - - case NBOUNDL: /* /\B/l */ + && UCHARAT(s) != fold_array[nextbyte]) + { + sayNO; + } + if (loceol - locinput < ln) + sayNO; + if (ln > 1 && ! folder(locinput, s, ln)) + sayNO; + locinput += ln; + break; + } + + case NBOUNDL: /* /\B/l */ to_complement = 1; /* FALLTHROUGH */ - case BOUNDL: /* /\b/l */ + case BOUNDL: /* /\b/l */ { bool b1, b2; _CHECK_AND_WARN_PROBLEMATIC_LOCALE; @@ -7079,48 +7079,48 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) goto boundu; } - if (utf8_target) { - if (locinput == reginfo->strbeg) - b1 = isWORDCHAR_LC('\n'); - else { + if (utf8_target) { + if (locinput == reginfo->strbeg) + b1 = isWORDCHAR_LC('\n'); + else { U8 *p = reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg)); b1 = isWORDCHAR_LC_utf8_safe(p, (U8*)(reginfo->strend)); - } + } b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC_utf8_safe((U8*) locinput, (U8*) reginfo->strend); - } - else { /* Here the string isn't utf8 */ - b1 = (locinput == reginfo->strbeg) + } + else { /* Here the string isn't utf8 */ + b1 = (locinput == reginfo->strbeg) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(UCHARAT(locinput - 1)); b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(nextbyte); - } + } if (to_complement ^ (b1 == b2)) { sayNO; } - break; + break; } - case NBOUND: /* /\B/ */ + case NBOUND: /* /\B/ */ to_complement = 1; /* FALLTHROUGH */ - case BOUND: /* /\b/ */ - if (utf8_target) { + case BOUND: /* /\b/ */ + if (utf8_target) { goto bound_utf8; } goto bound_ascii_match_only; - case NBOUNDA: /* /\B/a */ + case NBOUNDA: /* /\B/a */ to_complement = 1; /* FALLTHROUGH */ - case BOUNDA: /* /\b/a */ + case BOUNDA: /* /\b/a */ { bool b1, b2; @@ -7143,14 +7143,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (to_complement ^ (b1 == b2)) { sayNO; } - break; + break; } - case NBOUNDU: /* /\B/u */ + case NBOUNDU: /* /\B/u */ to_complement = 1; /* FALLTHROUGH */ - case BOUNDU: /* /\b/u */ + case BOUNDU: /* /\b/u */ boundu: if (UNLIKELY(reginfo->strbeg >= reginfo->strend)) { @@ -7260,8 +7260,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } break; } - } - else { /* Not utf8 target */ + } + else { /* Not utf8 target */ switch((bound_type) FLAGS(scan)) { case TRADITIONAL_BOUND: { @@ -7334,40 +7334,40 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } break; } - } + } if (to_complement ^ ! match) { sayNO; } - break; + break; case ANYOFPOSIXL: - case ANYOFL: /* /[abc]/l */ + case ANYOFL: /* /[abc]/l */ _CHECK_AND_WARN_PROBLEMATIC_LOCALE; CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_SETS(scan); /* FALLTHROUGH */ - case ANYOFD: /* /[abc]/d */ - case ANYOF: /* /[abc]/ */ + case ANYOFD: /* /[abc]/d */ + case ANYOF: /* /[abc]/ */ if (NEXTCHR_IS_EOS || locinput >= loceol) sayNO; - if ( (! utf8_target || UTF8_IS_INVARIANT(*locinput)) - && ! (ANYOF_FLAGS(scan) & ~ ANYOF_MATCHES_ALL_ABOVE_BITMAP)) + if ( (! utf8_target || UTF8_IS_INVARIANT(*locinput)) + && ! (ANYOF_FLAGS(scan) & ~ ANYOF_MATCHES_ALL_ABOVE_BITMAP)) { if (! ANYOF_BITMAP_TEST(scan, * (U8 *) (locinput))) { - sayNO; + sayNO; } - locinput++; + locinput++; } else { - if (!reginclass(rex, scan, (U8*)locinput, (U8*) loceol, + if (!reginclass(rex, scan, (U8*)locinput, (U8*) loceol, utf8_target)) { - sayNO; + sayNO; } goto increment_locinput; } - break; + break; case ANYOFM: if ( NEXTCHR_IS_EOS @@ -7393,7 +7393,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if ( ! utf8_target || NEXTCHR_IS_EOS || ANYOF_FLAGS(scan) > NATIVE_UTF8_TO_I8(*locinput) - || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, + || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, utf8_target)) { sayNO; @@ -7405,7 +7405,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if ( ! utf8_target || NEXTCHR_IS_EOS || ANYOF_FLAGS(scan) != (U8) *locinput - || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, + || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, utf8_target)) { sayNO; @@ -7419,7 +7419,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) || ! inRANGE((U8) NATIVE_UTF8_TO_I8(*locinput), LOWEST_ANYOF_HRx_BYTE(ANYOF_FLAGS(scan)), HIGHEST_ANYOF_HRx_BYTE(ANYOF_FLAGS(scan))) - || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, + || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, utf8_target)) { sayNO; @@ -7432,7 +7432,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) || NEXTCHR_IS_EOS || loceol - locinput < FLAGS(scan) || memNE(locinput, ((struct regnode_anyofhs *) scan)->string, FLAGS(scan)) - || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, + || ! reginclass(rex, scan, (U8*)locinput, (U8*) loceol, utf8_target)) { sayNO; @@ -7665,24 +7665,24 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } break; - case CLUMP: /* Match \X: logical Unicode character. This is defined as - a Unicode extended Grapheme Cluster */ - if (NEXTCHR_IS_EOS || locinput >= loceol) - sayNO; - if (! utf8_target) { - - /* Match either CR LF or '.', as all the other possibilities - * require utf8 */ - locinput++; /* Match the . or CR */ - if (nextbyte == '\r' /* And if it was CR, and the next is LF, - match the LF */ - && locinput < loceol - && UCHARAT(locinput) == '\n') + case CLUMP: /* Match \X: logical Unicode character. This is defined as + a Unicode extended Grapheme Cluster */ + if (NEXTCHR_IS_EOS || locinput >= loceol) + sayNO; + if (! utf8_target) { + + /* Match either CR LF or '.', as all the other possibilities + * require utf8 */ + locinput++; /* Match the . or CR */ + if (nextbyte == '\r' /* And if it was CR, and the next is LF, + match the LF */ + && locinput < loceol + && UCHARAT(locinput) == '\n') { locinput++; } - } - else { + } + else { /* Get the gcb type for the current character */ GCB_enum prev_gcb = getGCB_VAL_UTF8((U8*) locinput, @@ -7708,168 +7708,168 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } - } - break; + } + break; - case REFFLN: /* /\g{name}/il */ - { /* The capture buffer cases. The ones beginning with N for the - named buffers just convert to the equivalent numbered and - pretend they were called as the corresponding numbered buffer - op. */ - /* don't initialize these in the declaration, it makes C++ - unhappy */ - const char *s; - char type; - re_fold_t folder; - const U8 *fold_array; - UV utf8_fold_flags; + case REFFLN: /* /\g{name}/il */ + { /* The capture buffer cases. The ones beginning with N for the + named buffers just convert to the equivalent numbered and + pretend they were called as the corresponding numbered buffer + op. */ + /* don't initialize these in the declaration, it makes C++ + unhappy */ + const char *s; + char type; + re_fold_t folder; + const U8 *fold_array; + UV utf8_fold_flags; _CHECK_AND_WARN_PROBLEMATIC_LOCALE; - folder = foldEQ_locale; - fold_array = PL_fold_locale; - type = REFFL; - utf8_fold_flags = FOLDEQ_LOCALE; - goto do_nref; - - case REFFAN: /* /\g{name}/iaa */ - folder = foldEQ_latin1; - fold_array = PL_fold_latin1; - type = REFFA; - utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; - goto do_nref; - - case REFFUN: /* /\g{name}/iu */ - folder = foldEQ_latin1; - fold_array = PL_fold_latin1; - type = REFFU; - utf8_fold_flags = 0; - goto do_nref; - - case REFFN: /* /\g{name}/i */ - folder = foldEQ; - fold_array = PL_fold; - type = REFF; - utf8_fold_flags = 0; - goto do_nref; - - case REFN: /* /\g{name}/ */ - type = REF; - folder = NULL; - fold_array = NULL; - utf8_fold_flags = 0; - do_nref: - - /* For the named back references, find the corresponding buffer - * number */ - n = reg_check_named_buff_matched(rex,scan); + folder = foldEQ_locale; + fold_array = PL_fold_locale; + type = REFFL; + utf8_fold_flags = FOLDEQ_LOCALE; + goto do_nref; + + case REFFAN: /* /\g{name}/iaa */ + folder = foldEQ_latin1; + fold_array = PL_fold_latin1; + type = REFFA; + utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; + goto do_nref; + + case REFFUN: /* /\g{name}/iu */ + folder = foldEQ_latin1; + fold_array = PL_fold_latin1; + type = REFFU; + utf8_fold_flags = 0; + goto do_nref; + + case REFFN: /* /\g{name}/i */ + folder = foldEQ; + fold_array = PL_fold; + type = REFF; + utf8_fold_flags = 0; + goto do_nref; + + case REFN: /* /\g{name}/ */ + type = REF; + folder = NULL; + fold_array = NULL; + utf8_fold_flags = 0; + do_nref: + + /* For the named back references, find the corresponding buffer + * number */ + n = reg_check_named_buff_matched(rex,scan); if ( ! n ) { sayNO; - } - goto do_nref_ref_common; + } + goto do_nref_ref_common; - case REFFL: /* /\1/il */ + case REFFL: /* /\1/il */ _CHECK_AND_WARN_PROBLEMATIC_LOCALE; - folder = foldEQ_locale; - fold_array = PL_fold_locale; - utf8_fold_flags = FOLDEQ_LOCALE; - goto do_ref; - - case REFFA: /* /\1/iaa */ - folder = foldEQ_latin1; - fold_array = PL_fold_latin1; - utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; - goto do_ref; - - case REFFU: /* /\1/iu */ - folder = foldEQ_latin1; - fold_array = PL_fold_latin1; - utf8_fold_flags = 0; - goto do_ref; - - case REFF: /* /\1/i */ - folder = foldEQ; - fold_array = PL_fold; - utf8_fold_flags = 0; - goto do_ref; + folder = foldEQ_locale; + fold_array = PL_fold_locale; + utf8_fold_flags = FOLDEQ_LOCALE; + goto do_ref; + + case REFFA: /* /\1/iaa */ + folder = foldEQ_latin1; + fold_array = PL_fold_latin1; + utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; + goto do_ref; + + case REFFU: /* /\1/iu */ + folder = foldEQ_latin1; + fold_array = PL_fold_latin1; + utf8_fold_flags = 0; + goto do_ref; + + case REFF: /* /\1/i */ + folder = foldEQ; + fold_array = PL_fold; + utf8_fold_flags = 0; + goto do_ref; case REF: /* /\1/ */ - folder = NULL; - fold_array = NULL; - utf8_fold_flags = 0; - - do_ref: - type = OP(scan); - n = ARG(scan); /* which paren pair */ - - do_nref_ref_common: - ln = rex->offs[n].start; - endref = rex->offs[n].end; - reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ - if (rex->lastparen < n || ln == -1 || endref == -1) - sayNO; /* Do not match unless seen CLOSEn. */ - if (ln == endref) - break; - - s = reginfo->strbeg + ln; - if (type != REF /* REF can do byte comparison */ - && (utf8_target || type == REFFU || type == REFFL)) - { - char * limit = loceol; - - /* This call case insensitively compares the entire buffer - * at s, with the current input starting at locinput, but + folder = NULL; + fold_array = NULL; + utf8_fold_flags = 0; + + do_ref: + type = OP(scan); + n = ARG(scan); /* which paren pair */ + + do_nref_ref_common: + ln = rex->offs[n].start; + endref = rex->offs[n].end; + reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ + if (rex->lastparen < n || ln == -1 || endref == -1) + sayNO; /* Do not match unless seen CLOSEn. */ + if (ln == endref) + break; + + s = reginfo->strbeg + ln; + if (type != REF /* REF can do byte comparison */ + && (utf8_target || type == REFFU || type == REFFL)) + { + char * limit = loceol; + + /* This call case insensitively compares the entire buffer + * at s, with the current input starting at locinput, but * not going off the end given by loceol, and * returns in upon success, how much of the * current input was matched */ - if (! foldEQ_utf8_flags(s, NULL, endref - ln, utf8_target, - locinput, &limit, 0, utf8_target, utf8_fold_flags)) - { - sayNO; - } - locinput = limit; - break; - } - - /* Not utf8: Inline the first character, for speed. */ - if ( ! NEXTCHR_IS_EOS + if (! foldEQ_utf8_flags(s, NULL, endref - ln, utf8_target, + locinput, &limit, 0, utf8_target, utf8_fold_flags)) + { + sayNO; + } + locinput = limit; + break; + } + + /* Not utf8: Inline the first character, for speed. */ + if ( ! NEXTCHR_IS_EOS && locinput < loceol && UCHARAT(s) != nextbyte && ( type == REF || UCHARAT(s) != fold_array[nextbyte])) { - sayNO; - } - ln = endref - ln; - if (locinput + ln > loceol) - sayNO; - if (ln > 1 && (type == REF - ? memNE(s, locinput, ln) - : ! folder(locinput, s, ln))) - sayNO; - locinput += ln; - break; - } - - case NOTHING: /* null op; e.g. the 'nothing' following + sayNO; + } + ln = endref - ln; + if (locinput + ln > loceol) + sayNO; + if (ln > 1 && (type == REF + ? memNE(s, locinput, ln) + : ! folder(locinput, s, ln))) + sayNO; + locinput += ln; + break; + } + + case NOTHING: /* null op; e.g. the 'nothing' following * the '*' in m{(a+|b)*}' */ - break; - case TAIL: /* placeholder while compiling (A|B|C) */ - break; + break; + case TAIL: /* placeholder while compiling (A|B|C) */ + break; #undef ST #define ST st->u.eval #define CUR_EVAL cur_eval->u.eval - { - SV *ret; - REGEXP *re_sv; + { + SV *ret; + REGEXP *re_sv; regexp *re; regexp_internal *rei; regnode *startpoint; U32 arg; - case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */ + case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */ arg= (U32)ARG(scan); if (cur_eval && cur_eval->locinput == locinput) { if ( ++nochange_depth > max_nochange_depth ) @@ -7879,7 +7879,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } else { nochange_depth = 0; } - re_sv = rex_sv; + re_sv = rex_sv; re = rex; rei = rexi; startpoint = scan + ARG2L(scan); @@ -7921,47 +7921,47 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EVAL: /* /(?{...})B/ /(??{A})B/ and /(?(?{...})X|Y)B/ */ if (logical == 2 && cur_eval && cur_eval->locinput==locinput) { - if ( ++nochange_depth > max_nochange_depth ) + if ( ++nochange_depth > max_nochange_depth ) Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex"); } else { nochange_depth = 0; } - { - /* execute the code in the {...} */ + { + /* execute the code in the {...} */ - dSP; - IV before; - OP * const oop = PL_op; - COP * const ocurcop = PL_curcop; - OP *nop; - CV *newcv; + dSP; + IV before; + OP * const oop = PL_op; + COP * const ocurcop = PL_curcop; + OP *nop; + CV *newcv; - /* save *all* paren positions */ + /* save *all* paren positions */ regcppush(rex, 0, maxopenparen); REGCP_SET(ST.lastcp); - if (!caller_cv) - caller_cv = find_runcv(NULL); + if (!caller_cv) + caller_cv = find_runcv(NULL); - n = ARG(scan); + n = ARG(scan); - if (rexi->data->what[n] == 'r') { /* code from an external qr */ + if (rexi->data->what[n] == 'r') { /* code from an external qr */ newcv = (ReANY( (REGEXP*)(rexi->data->data[n]) ))->qr_anoncv; - nop = (OP*)rexi->data->data[n+1]; - } - else if (rexi->data->what[n] == 'l') { /* literal code */ - newcv = caller_cv; - nop = (OP*)rexi->data->data[n]; - assert(CvDEPTH(newcv)); - } - else { - /* literal with own CV */ - assert(rexi->data->what[n] == 'L'); - newcv = rex->qr_anoncv; - nop = (OP*)rexi->data->data[n]; - } + nop = (OP*)rexi->data->data[n+1]; + } + else if (rexi->data->what[n] == 'l') { /* literal code */ + newcv = caller_cv; + nop = (OP*)rexi->data->data[n]; + assert(CvDEPTH(newcv)); + } + else { + /* literal with own CV */ + assert(rexi->data->what[n] == 'L'); + newcv = rex->qr_anoncv; + nop = (OP*)rexi->data->data[n]; + } /* Some notes about MULTICALL and the context and save stacks. * @@ -8010,65 +8010,65 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * if PL_comppad has got messed up from backtracking * through SAVECOMPPADs, then refresh the context. */ - if (newcv != last_pushed_cv || PL_comppad != last_pad) - { + if (newcv != last_pushed_cv || PL_comppad != last_pad) + { U8 flags = (CXp_SUB_RE | ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0)); SAVECOMPPAD(); - if (last_pushed_cv) { - CHANGE_MULTICALL_FLAGS(newcv, flags); - } - else { - PUSH_MULTICALL_FLAGS(newcv, flags); - } + if (last_pushed_cv) { + CHANGE_MULTICALL_FLAGS(newcv, flags); + } + else { + PUSH_MULTICALL_FLAGS(newcv, flags); + } /* see notes above */ CX_CUR()->blk_oldsaveix = orig_savestack_ix; - last_pushed_cv = newcv; - } - else { + last_pushed_cv = newcv; + } + else { /* these assignments are just to silence compiler * warnings */ - multicall_cop = NULL; - } - last_pad = PL_comppad; - - /* the initial nextstate you would normally execute - * at the start of an eval (which would cause error - * messages to come from the eval), may be optimised - * away from the execution path in the regex code blocks; - * so manually set PL_curcop to it initially */ - { - OP *o = cUNOPx(nop)->op_first; - assert(o->op_type == OP_NULL); - if (o->op_targ == OP_SCOPE) { - o = cUNOPo->op_first; - } - else { - assert(o->op_targ == OP_LEAVE); - o = cUNOPo->op_first; - assert(o->op_type == OP_ENTER); - o = OpSIBLING(o); - } - - if (o->op_type != OP_STUB) { - assert( o->op_type == OP_NEXTSTATE - || o->op_type == OP_DBSTATE - || (o->op_type == OP_NULL - && ( o->op_targ == OP_NEXTSTATE - || o->op_targ == OP_DBSTATE - ) - ) - ); - PL_curcop = (COP*)o; - } - } - nop = nop->op_next; + multicall_cop = NULL; + } + last_pad = PL_comppad; + + /* the initial nextstate you would normally execute + * at the start of an eval (which would cause error + * messages to come from the eval), may be optimised + * away from the execution path in the regex code blocks; + * so manually set PL_curcop to it initially */ + { + OP *o = cUNOPx(nop)->op_first; + assert(o->op_type == OP_NULL); + if (o->op_targ == OP_SCOPE) { + o = cUNOPo->op_first; + } + else { + assert(o->op_targ == OP_LEAVE); + o = cUNOPo->op_first; + assert(o->op_type == OP_ENTER); + o = OpSIBLING(o); + } + + if (o->op_type != OP_STUB) { + assert( o->op_type == OP_NEXTSTATE + || o->op_type == OP_DBSTATE + || (o->op_type == OP_NULL + && ( o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE + ) + ) + ); + PL_curcop = (COP*)o; + } + } + nop = nop->op_next; DEBUG_STATE_r( Perl_re_printf( aTHX_ - " re EVAL PL_op=0x%" UVxf "\n", PTR2UV(nop)) ); + " re EVAL PL_op=0x%" UVxf "\n", PTR2UV(nop)) ); - rex->offs[0].end = locinput - reginfo->strbeg; + rex->offs[0].end = locinput - reginfo->strbeg; if (reginfo->info_aux_eval->pos_magic) MgBYTEPOS_set(reginfo->info_aux_eval->pos_magic, reginfo->sv, reginfo->strbeg, @@ -8079,125 +8079,125 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sv_setsv(sv_mrk, sv_yes_mark); } - /* we don't use MULTICALL here as we want to call the - * first op of the block of interest, rather than the - * first op of the sub. Also, we don't want to free + /* we don't use MULTICALL here as we want to call the + * first op of the block of interest, rather than the + * first op of the sub. Also, we don't want to free * the savestack frame */ - before = (IV)(SP-PL_stack_base); - PL_op = nop; - CALLRUNOPS(aTHX); /* Scalar context. */ - SPAGAIN; - if ((IV)(SP-PL_stack_base) == before) - ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */ - else { - ret = POPs; - PUTBACK; - } - - /* before restoring everything, evaluate the returned - * value, so that 'uninit' warnings don't use the wrong - * PL_op or pad. Also need to process any magic vars - * (e.g. $1) *before* parentheses are restored */ - - PL_op = NULL; + before = (IV)(SP-PL_stack_base); + PL_op = nop; + CALLRUNOPS(aTHX); /* Scalar context. */ + SPAGAIN; + if ((IV)(SP-PL_stack_base) == before) + ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */ + else { + ret = POPs; + PUTBACK; + } + + /* before restoring everything, evaluate the returned + * value, so that 'uninit' warnings don't use the wrong + * PL_op or pad. Also need to process any magic vars + * (e.g. $1) *before* parentheses are restored */ + + PL_op = NULL; re_sv = NULL; - if (logical == 0) { /* (?{})/ */ + if (logical == 0) { /* (?{})/ */ SV *replsv = save_scalar(PL_replgv); sv_setsv(replsv, ret); /* $^R */ SvSETMAGIC(replsv); } - else if (logical == 1) { /* /(?(?{...})X|Y)/ */ - sw = cBOOL(SvTRUE_NN(ret)); - logical = 0; - } - else { /* /(??{}) */ - /* if its overloaded, let the regex compiler handle - * it; otherwise extract regex, or stringify */ - if (SvGMAGICAL(ret)) - ret = sv_mortalcopy(ret); - if (!SvAMAGIC(ret)) { - SV *sv = ret; - if (SvROK(sv)) - sv = SvRV(sv); - if (SvTYPE(sv) == SVt_REGEXP) - re_sv = (REGEXP*) sv; - else if (SvSMAGICAL(ret)) { - MAGIC *mg = mg_find(ret, PERL_MAGIC_qr); - if (mg) - re_sv = (REGEXP *) mg->mg_obj; - } - - /* force any undef warnings here */ - if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) { - ret = sv_mortalcopy(ret); - (void) SvPV_force_nolen(ret); - } - } - - } - - /* *** Note that at this point we don't restore - * PL_comppad, (or pop the CxSUB) on the assumption it may - * be used again soon. This is safe as long as nothing - * in the regexp code uses the pad ! */ - PL_op = oop; - PL_curcop = ocurcop; + else if (logical == 1) { /* /(?(?{...})X|Y)/ */ + sw = cBOOL(SvTRUE_NN(ret)); + logical = 0; + } + else { /* /(??{}) */ + /* if its overloaded, let the regex compiler handle + * it; otherwise extract regex, or stringify */ + if (SvGMAGICAL(ret)) + ret = sv_mortalcopy(ret); + if (!SvAMAGIC(ret)) { + SV *sv = ret; + if (SvROK(sv)) + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_REGEXP) + re_sv = (REGEXP*) sv; + else if (SvSMAGICAL(ret)) { + MAGIC *mg = mg_find(ret, PERL_MAGIC_qr); + if (mg) + re_sv = (REGEXP *) mg->mg_obj; + } + + /* force any undef warnings here */ + if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) { + ret = sv_mortalcopy(ret); + (void) SvPV_force_nolen(ret); + } + } + + } + + /* *** Note that at this point we don't restore + * PL_comppad, (or pop the CxSUB) on the assumption it may + * be used again soon. This is safe as long as nothing + * in the regexp code uses the pad ! */ + PL_op = oop; + PL_curcop = ocurcop; regcp_restore(rex, ST.lastcp, &maxopenparen); PL_curpm_under = PL_curpm; PL_curpm = PL_reg_curpm; - if (logical != 2) { + if (logical != 2) { PUSH_STATE_GOTO(EVAL_B, next, locinput, loceol, script_run_begin); - /* NOTREACHED */ - } - } - - /* only /(??{})/ from now on */ - logical = 0; - { - /* extract RE object from returned value; compiling if - * necessary */ - - if (re_sv) { - re_sv = reg_temp_copy(NULL, re_sv); - } - else { - U32 pm_flags = 0; - - if (SvUTF8(ret) && IN_BYTES) { - /* In use 'bytes': make a copy of the octet - * sequence, but without the flag on */ - STRLEN len; - const char *const p = SvPV(ret, len); - ret = newSVpvn_flags(p, len, SVs_TEMP); - } - if (rex->intflags & PREGf_USE_RE_EVAL) - pm_flags |= PMf_USE_RE_EVAL; - - /* if we got here, it should be an engine which - * supports compiling code blocks and stuff */ - assert(rex->engine && rex->engine->op_comp); + /* NOTREACHED */ + } + } + + /* only /(??{})/ from now on */ + logical = 0; + { + /* extract RE object from returned value; compiling if + * necessary */ + + if (re_sv) { + re_sv = reg_temp_copy(NULL, re_sv); + } + else { + U32 pm_flags = 0; + + if (SvUTF8(ret) && IN_BYTES) { + /* In use 'bytes': make a copy of the octet + * sequence, but without the flag on */ + STRLEN len; + const char *const p = SvPV(ret, len); + ret = newSVpvn_flags(p, len, SVs_TEMP); + } + if (rex->intflags & PREGf_USE_RE_EVAL) + pm_flags |= PMf_USE_RE_EVAL; + + /* if we got here, it should be an engine which + * supports compiling code blocks and stuff */ + assert(rex->engine && rex->engine->op_comp); assert(!(scan->flags & ~RXf_PMf_COMPILETIME)); - re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL, - rex->engine, NULL, NULL, + re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL, + rex->engine, NULL, NULL, /* copy /msixn etc to inner pattern */ ARG2L(scan), pm_flags); - if (!(SvFLAGS(ret) - & (SVs_TEMP | SVs_GMG | SVf_ROK)) - && (!SvPADTMP(ret) || SvREADONLY(ret))) { - /* This isn't a first class regexp. Instead, it's - caching a regexp onto an existing, Perl visible - scalar. */ - sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0); - } - } - SAVEFREESV(re_sv); - re = ReANY(re_sv); - } + if (!(SvFLAGS(ret) + & (SVs_TEMP | SVs_GMG | SVf_ROK)) + && (!SvPADTMP(ret) || SvREADONLY(ret))) { + /* This isn't a first class regexp. Instead, it's + caching a regexp onto an existing, Perl visible + scalar. */ + sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0); + } + } + SAVEFREESV(re_sv); + re = ReANY(re_sv); + } RXp_MATCH_COPIED_off(re); re->subbeg = rex->subbeg; re->sublen = rex->sublen; @@ -8205,12 +8205,12 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) re->subcoffset = rex->subcoffset; re->lastparen = 0; re->lastcloseparen = 0; - rei = RXi_GET(re); + rei = RXi_GET(re); DEBUG_EXECUTE_r( debug_start_match(re_sv, utf8_target, locinput, reginfo->strend, "EVAL/GOSUB: Matching embedded"); - ); - startpoint = rei->program + 1; + ); + startpoint = rei->program + 1; EVAL_CLOSE_PAREN_CLEAR(st); /* ST.close_paren = 0; * close_paren only for GOSUB */ ST.prev_recurse_locinput= NULL; /* only used for GOSUB */ @@ -8230,31 +8230,31 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * indexes) against the same string, so the bits in the * cache are meaningless. Setting maxiter to zero forces * the cache to be invalidated and zeroed before reuse. - * XXX This is too dramatic a measure. Ideally we should + * XXX This is too dramatic a measure. Ideally we should * save the old cache and restore when running the outer * pattern again */ - reginfo->poscache_maxiter = 0; + reginfo->poscache_maxiter = 0; /* the new regexp might have a different is_utf8_pat than we do */ is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(re_sv)); - ST.prev_rex = rex_sv; - ST.prev_curlyx = cur_curlyx; - rex_sv = re_sv; - SET_reg_curpm(rex_sv); - rex = re; - rexi = rei; - cur_curlyx = NULL; - ST.B = next; - ST.prev_eval = cur_eval; - cur_eval = st; - /* now continue from first node in postoned RE */ - PUSH_YES_STATE_GOTO(EVAL_postponed_AB, startpoint, locinput, + ST.prev_rex = rex_sv; + ST.prev_curlyx = cur_curlyx; + rex_sv = re_sv; + SET_reg_curpm(rex_sv); + rex = re; + rexi = rei; + cur_curlyx = NULL; + ST.B = next; + ST.prev_eval = cur_eval; + cur_eval = st; + /* now continue from first node in postoned RE */ + PUSH_YES_STATE_GOTO(EVAL_postponed_AB, startpoint, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } + NOT_REACHED; /* NOTREACHED */ + } - case EVAL_postponed_AB: /* cleanup after a successful (??{A})B */ + case EVAL_postponed_AB: /* cleanup after a successful (??{A})B */ /* note: this is called twice; first after popping B, then A */ DEBUG_STACK_r({ Perl_re_exec_indentf( aTHX_ "EVAL_AB cur_eval=%p prev_eval=%p\n", @@ -8275,11 +8275,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SET_RECURSE_LOCINPUT("EVAL_AB[before]", CUR_EVAL.prev_recurse_locinput); - rex_sv = ST.prev_rex; + rex_sv = ST.prev_rex; is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); - SET_reg_curpm(rex_sv); - rex = ReANY(rex_sv); - rexi = RXi_GET(rex); + SET_reg_curpm(rex_sv); + rex = ReANY(rex_sv); + rexi = RXi_GET(rex); { /* preserve $^R across LEAVE's. See Bug 121070. */ SV *save_sv= GvSV(PL_replgv); @@ -8292,24 +8292,24 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SvSETMAGIC(replsv); SvREFCNT_dec(save_sv); } - cur_eval = ST.prev_eval; - cur_curlyx = ST.prev_curlyx; + cur_eval = ST.prev_eval; + cur_curlyx = ST.prev_curlyx; - /* Invalidate cache. See "invalidate" comment above. */ - reginfo->poscache_maxiter = 0; + /* Invalidate cache. See "invalidate" comment above. */ + reginfo->poscache_maxiter = 0; if ( nochange_depth ) - nochange_depth--; + nochange_depth--; SET_RECURSE_LOCINPUT("EVAL_AB[after]", cur_eval->locinput); - sayYES; + sayYES; - case EVAL_B_fail: /* unsuccessful B in (?{...})B */ - REGCP_UNWIND(ST.lastcp); + case EVAL_B_fail: /* unsuccessful B in (?{...})B */ + REGCP_UNWIND(ST.lastcp); sayNO; - case EVAL_postponed_AB_fail: /* unsuccessfully ran A or B in (??{A})B */ - /* note: this is called twice; first after popping B, then A */ + case EVAL_postponed_AB_fail: /* unsuccessfully ran A or B in (??{A})B */ + /* note: this is called twice; first after popping B, then A */ DEBUG_STACK_r({ Perl_re_exec_indentf( aTHX_ "EVAL_AB_fail cur_eval=%p prev_eval=%p\n", depth, cur_eval, ST.prev_eval); @@ -8317,56 +8317,56 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SET_RECURSE_LOCINPUT("EVAL_AB_fail[before]", CUR_EVAL.prev_recurse_locinput); - rex_sv = ST.prev_rex; + rex_sv = ST.prev_rex; is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); - SET_reg_curpm(rex_sv); - rex = ReANY(rex_sv); - rexi = RXi_GET(rex); + SET_reg_curpm(rex_sv); + rex = ReANY(rex_sv); + rexi = RXi_GET(rex); - REGCP_UNWIND(ST.lastcp); + REGCP_UNWIND(ST.lastcp); regcppop(rex, &maxopenparen); - cur_eval = ST.prev_eval; - cur_curlyx = ST.prev_curlyx; + cur_eval = ST.prev_eval; + cur_curlyx = ST.prev_curlyx; - /* Invalidate cache. See "invalidate" comment above. */ - reginfo->poscache_maxiter = 0; - if ( nochange_depth ) - nochange_depth--; + /* Invalidate cache. See "invalidate" comment above. */ + reginfo->poscache_maxiter = 0; + if ( nochange_depth ) + nochange_depth--; SET_RECURSE_LOCINPUT("EVAL_AB_fail[after]", cur_eval->locinput); sayNO_SILENT; #undef ST - case OPEN: /* ( */ - n = ARG(scan); /* which paren pair */ - rex->offs[n].start_tmp = locinput - reginfo->strbeg; - if (n > maxopenparen) - maxopenparen = n; + case OPEN: /* ( */ + n = ARG(scan); /* which paren pair */ + rex->offs[n].start_tmp = locinput - reginfo->strbeg; + if (n > maxopenparen) + maxopenparen = n; DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ - "OPEN: rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " tmp; maxopenparen=%" UVuf "\n", + "OPEN: rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " tmp; maxopenparen=%" UVuf "\n", depth, - PTR2UV(rex), - PTR2UV(rex->offs), - (UV)n, - (IV)rex->offs[n].start_tmp, - (UV)maxopenparen - )); + PTR2UV(rex), + PTR2UV(rex->offs), + (UV)n, + (IV)rex->offs[n].start_tmp, + (UV)maxopenparen + )); lastopen = n; - break; + break; case SROPEN: /* (*SCRIPT_RUN: */ script_run_begin = (U8 *) locinput; break; - case CLOSE: /* ) */ - n = ARG(scan); /* which paren pair */ - CLOSE_CAPTURE(n, rex->offs[n].start_tmp, + case CLOSE: /* ) */ + n = ARG(scan); /* which paren pair */ + CLOSE_CAPTURE(n, rex->offs[n].start_tmp, locinput - reginfo->strbeg); if ( EVAL_CLOSE_PAREN_IS( cur_eval, n ) ) - goto fake_end; + goto fake_end; - break; + break; case SRCLOSE: /* (*SCRIPT_RUN: ... ) */ @@ -8390,7 +8390,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if ( OP(cursor)==CLOSE ){ n = ARG(cursor); if ( n <= lastopen ) { - CLOSE_CAPTURE(n, rex->offs[n].start_tmp, + CLOSE_CAPTURE(n, rex->offs[n].start_tmp, locinput - reginfo->strbeg); if ( n == ARG(scan) || EVAL_CLOSE_PAREN_IS(cur_eval, n) ) break; @@ -8398,18 +8398,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } } } - goto fake_end; - /* NOTREACHED */ + goto fake_end; + /* NOTREACHED */ - case GROUPP: /* (?(1)) */ - n = ARG(scan); /* which paren pair */ - sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1); - break; + case GROUPP: /* (?(1)) */ + n = ARG(scan); /* which paren pair */ + sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1); + break; - case GROUPPN: /* (?()) */ - /* reg_check_named_buff_matched returns 0 for no match */ - sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan)); - break; + case GROUPPN: /* (?()) */ + /* reg_check_named_buff_matched returns 0 for no match */ + sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan)); + break; case INSUBP: /* (?(R)) */ n = ARG(scan); @@ -8422,20 +8422,20 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sw = 0; break; - case IFTHEN: /* (?(cond)A|B) */ - reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ - if (sw) - next = NEXTOPER(NEXTOPER(scan)); - else { - next = scan + ARG(scan); - if (OP(next) == IFTHEN) /* Fake one. */ - next = NEXTOPER(NEXTOPER(next)); - } - break; - - case LOGICAL: /* modifier for EVAL and IFMATCH */ - logical = scan->flags; - break; + case IFTHEN: /* (?(cond)A|B) */ + reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ + if (sw) + next = NEXTOPER(NEXTOPER(scan)); + else { + next = scan + ARG(scan); + if (OP(next) == IFTHEN) /* Fake one. */ + next = NEXTOPER(NEXTOPER(next)); + } + break; + + case LOGICAL: /* modifier for EVAL and IFMATCH */ + logical = scan->flags; + break; /******************************************************************* @@ -8522,98 +8522,98 @@ NULL #define ST st->u.curlyx - case CURLYX: /* start of /A*B/ (for complex A) */ - { - /* No need to save/restore up to this paren */ - I32 parenfloor = scan->flags; - - assert(next); /* keep Coverity happy */ - if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */ - next += ARG(next); - - /* XXXX Probably it is better to teach regpush to support - parenfloor > maxopenparen ... */ - if (parenfloor > (I32)rex->lastparen) - parenfloor = rex->lastparen; /* Pessimization... */ - - ST.prev_curlyx= cur_curlyx; - cur_curlyx = st; - ST.cp = PL_savestack_ix; - - /* these fields contain the state of the current curly. - * they are accessed by subsequent WHILEMs */ - ST.parenfloor = parenfloor; - ST.me = scan; - ST.B = next; - ST.minmod = minmod; - minmod = 0; - ST.count = -1; /* this will be updated by WHILEM */ - ST.lastloc = NULL; /* this will be updated by WHILEM */ - - PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput, loceol, + case CURLYX: /* start of /A*B/ (for complex A) */ + { + /* No need to save/restore up to this paren */ + I32 parenfloor = scan->flags; + + assert(next); /* keep Coverity happy */ + if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */ + next += ARG(next); + + /* XXXX Probably it is better to teach regpush to support + parenfloor > maxopenparen ... */ + if (parenfloor > (I32)rex->lastparen) + parenfloor = rex->lastparen; /* Pessimization... */ + + ST.prev_curlyx= cur_curlyx; + cur_curlyx = st; + ST.cp = PL_savestack_ix; + + /* these fields contain the state of the current curly. + * they are accessed by subsequent WHILEMs */ + ST.parenfloor = parenfloor; + ST.me = scan; + ST.B = next; + ST.minmod = minmod; + minmod = 0; + ST.count = -1; /* this will be updated by WHILEM */ + ST.lastloc = NULL; /* this will be updated by WHILEM */ + + PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } + NOT_REACHED; /* NOTREACHED */ + } - case CURLYX_end: /* just finished matching all of A*B */ - cur_curlyx = ST.prev_curlyx; - sayYES; - NOT_REACHED; /* NOTREACHED */ + case CURLYX_end: /* just finished matching all of A*B */ + cur_curlyx = ST.prev_curlyx; + sayYES; + NOT_REACHED; /* NOTREACHED */ - case CURLYX_end_fail: /* just failed to match all of A*B */ - regcpblow(ST.cp); - cur_curlyx = ST.prev_curlyx; - sayNO; - NOT_REACHED; /* NOTREACHED */ + case CURLYX_end_fail: /* just failed to match all of A*B */ + regcpblow(ST.cp); + cur_curlyx = ST.prev_curlyx; + sayNO; + NOT_REACHED; /* NOTREACHED */ #undef ST #define ST st->u.whilem - case WHILEM: /* just matched an A in /A*B/ (for complex A) */ - { - /* see the discussion above about CURLYX/WHILEM */ - I32 n; - int min, max; - regnode *A; + case WHILEM: /* just matched an A in /A*B/ (for complex A) */ + { + /* see the discussion above about CURLYX/WHILEM */ + I32 n; + int min, max; + regnode *A; - assert(cur_curlyx); /* keep Coverity happy */ + assert(cur_curlyx); /* keep Coverity happy */ - min = ARG1(cur_curlyx->u.curlyx.me); - max = ARG2(cur_curlyx->u.curlyx.me); - A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS; - n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */ - ST.save_lastloc = cur_curlyx->u.curlyx.lastloc; - ST.cache_offset = 0; - ST.cache_mask = 0; + min = ARG1(cur_curlyx->u.curlyx.me); + max = ARG2(cur_curlyx->u.curlyx.me); + A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS; + n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */ + ST.save_lastloc = cur_curlyx->u.curlyx.lastloc; + ST.cache_offset = 0; + ST.cache_mask = 0; DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: matched %ld out of %d..%d\n", depth, (long)n, min, max) - ); + ); - /* First just match a string of min A's. */ + /* First just match a string of min A's. */ - if (n < min) { + if (n < min) { ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, maxopenparen); - cur_curlyx->u.curlyx.lastloc = locinput; - REGCP_SET(ST.lastcp); + cur_curlyx->u.curlyx.lastloc = locinput; + REGCP_SET(ST.lastcp); - PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput, loceol, + PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } + NOT_REACHED; /* NOTREACHED */ + } - /* If degenerate A matches "", assume A done. */ + /* If degenerate A matches "", assume A done. */ - if (locinput == cur_curlyx->u.curlyx.lastloc) { + if (locinput == cur_curlyx->u.curlyx.lastloc) { DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: empty match detected, trying continuation...\n", depth) - ); - goto do_whilem_B_max; - } + ); + goto do_whilem_B_max; + } - /* super-linear cache processing. + /* super-linear cache processing. * * The idea here is that for certain types of CURLYX/WHILEM - * principally those whose upper bound is infinity (and @@ -8645,193 +8645,193 @@ NULL * WHILEM. */ - if (scan->flags) { + if (scan->flags) { - if (!reginfo->poscache_maxiter) { - /* start the countdown: Postpone detection until we - * know the match is not *that* much linear. */ - reginfo->poscache_maxiter + if (!reginfo->poscache_maxiter) { + /* start the countdown: Postpone detection until we + * know the match is not *that* much linear. */ + reginfo->poscache_maxiter = (reginfo->strend - reginfo->strbeg + 1) * (scan->flags>>4); - /* possible overflow for long strings and many CURLYX's */ - if (reginfo->poscache_maxiter < 0) - reginfo->poscache_maxiter = I32_MAX; - reginfo->poscache_iter = reginfo->poscache_maxiter; - } - - if (reginfo->poscache_iter-- == 0) { - /* initialise cache */ - const SSize_t size = (reginfo->poscache_maxiter + 7)/8; + /* possible overflow for long strings and many CURLYX's */ + if (reginfo->poscache_maxiter < 0) + reginfo->poscache_maxiter = I32_MAX; + reginfo->poscache_iter = reginfo->poscache_maxiter; + } + + if (reginfo->poscache_iter-- == 0) { + /* initialise cache */ + const SSize_t size = (reginfo->poscache_maxiter + 7)/8; regmatch_info_aux *const aux = reginfo->info_aux; - if (aux->poscache) { - if ((SSize_t)reginfo->poscache_size < size) { - Renew(aux->poscache, size, char); - reginfo->poscache_size = size; - } - Zero(aux->poscache, size, char); - } - else { - reginfo->poscache_size = size; - Newxz(aux->poscache, size, char); - } + if (aux->poscache) { + if ((SSize_t)reginfo->poscache_size < size) { + Renew(aux->poscache, size, char); + reginfo->poscache_size = size; + } + Zero(aux->poscache, size, char); + } + else { + reginfo->poscache_size = size; + Newxz(aux->poscache, size, char); + } DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ "%sWHILEM: Detected a super-linear match, switching on caching%s...\n", - PL_colors[4], PL_colors[5]) - ); - } + PL_colors[4], PL_colors[5]) + ); + } - if (reginfo->poscache_iter < 0) { - /* have we already failed at this position? */ - SSize_t offset, mask; + if (reginfo->poscache_iter < 0) { + /* have we already failed at this position? */ + SSize_t offset, mask; reginfo->poscache_iter = -1; /* stop eventual underflow */ - offset = (scan->flags & 0xf) - 1 + offset = (scan->flags & 0xf) - 1 + (locinput - reginfo->strbeg) * (scan->flags>>4); - mask = 1 << (offset % 8); - offset /= 8; - if (reginfo->info_aux->poscache[offset] & mask) { + mask = 1 << (offset % 8); + offset /= 8; + if (reginfo->info_aux->poscache[offset] & mask) { DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: (cache) already tried at this position...\n", depth) - ); + ); cur_curlyx->u.curlyx.count--; - sayNO; /* cache records failure */ - } - ST.cache_offset = offset; - ST.cache_mask = mask; - } - } - - /* Prefer B over A for minimal matching. */ - - if (cur_curlyx->u.curlyx.minmod) { - ST.save_curlyx = cur_curlyx; - cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; - PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B, + sayNO; /* cache records failure */ + } + ST.cache_offset = offset; + ST.cache_mask = mask; + } + } + + /* Prefer B over A for minimal matching. */ + + if (cur_curlyx->u.curlyx.minmod) { + ST.save_curlyx = cur_curlyx; + cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; + PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } + NOT_REACHED; /* NOTREACHED */ + } - /* Prefer A over B for maximal matching. */ + /* Prefer A over B for maximal matching. */ - if (n < max) { /* More greed allowed? */ + if (n < max) { /* More greed allowed? */ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, maxopenparen); - cur_curlyx->u.curlyx.lastloc = locinput; - REGCP_SET(ST.lastcp); - PUSH_STATE_GOTO(WHILEM_A_max, A, locinput, loceol, + cur_curlyx->u.curlyx.lastloc = locinput; + REGCP_SET(ST.lastcp); + PUSH_STATE_GOTO(WHILEM_A_max, A, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ - } - goto do_whilem_B_max; - } - NOT_REACHED; /* NOTREACHED */ - - case WHILEM_B_min: /* just matched B in a minimal match */ - case WHILEM_B_max: /* just matched B in a maximal match */ - cur_curlyx = ST.save_curlyx; - sayYES; - NOT_REACHED; /* NOTREACHED */ - - case WHILEM_B_max_fail: /* just failed to match B in a maximal match */ - cur_curlyx = ST.save_curlyx; - cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; - cur_curlyx->u.curlyx.count--; - CACHEsayNO; - NOT_REACHED; /* NOTREACHED */ - - case WHILEM_A_min_fail: /* just failed to match A in a minimal match */ - /* FALLTHROUGH */ - case WHILEM_A_pre_fail: /* just failed to match even minimal A */ - REGCP_UNWIND(ST.lastcp); + NOT_REACHED; /* NOTREACHED */ + } + goto do_whilem_B_max; + } + NOT_REACHED; /* NOTREACHED */ + + case WHILEM_B_min: /* just matched B in a minimal match */ + case WHILEM_B_max: /* just matched B in a maximal match */ + cur_curlyx = ST.save_curlyx; + sayYES; + NOT_REACHED; /* NOTREACHED */ + + case WHILEM_B_max_fail: /* just failed to match B in a maximal match */ + cur_curlyx = ST.save_curlyx; + cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; + cur_curlyx->u.curlyx.count--; + CACHEsayNO; + NOT_REACHED; /* NOTREACHED */ + + case WHILEM_A_min_fail: /* just failed to match A in a minimal match */ + /* FALLTHROUGH */ + case WHILEM_A_pre_fail: /* just failed to match even minimal A */ + REGCP_UNWIND(ST.lastcp); regcppop(rex, &maxopenparen); - cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; - cur_curlyx->u.curlyx.count--; - CACHEsayNO; - NOT_REACHED; /* NOTREACHED */ + cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; + cur_curlyx->u.curlyx.count--; + CACHEsayNO; + NOT_REACHED; /* NOTREACHED */ - case WHILEM_A_max_fail: /* just failed to match A in a maximal match */ - REGCP_UNWIND(ST.lastcp); + case WHILEM_A_max_fail: /* just failed to match A in a maximal match */ + REGCP_UNWIND(ST.lastcp); regcppop(rex, &maxopenparen); /* Restore some previous $s? */ DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "WHILEM: failed, trying continuation...\n", depth) - ); - do_whilem_B_max: - if (cur_curlyx->u.curlyx.count >= REG_INFTY - && ckWARN(WARN_REGEXP) - && !reginfo->warned) - { + ); + do_whilem_B_max: + if (cur_curlyx->u.curlyx.count >= REG_INFTY + && ckWARN(WARN_REGEXP) + && !reginfo->warned) + { reginfo->warned = TRUE; - Perl_warner(aTHX_ packWARN(WARN_REGEXP), - "Complex regular subexpression recursion limit (%d) " - "exceeded", - REG_INFTY - 1); - } - - /* now try B */ - ST.save_curlyx = cur_curlyx; - cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; - PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B, + Perl_warner(aTHX_ packWARN(WARN_REGEXP), + "Complex regular subexpression recursion limit (%d) " + "exceeded", + REG_INFTY - 1); + } + + /* now try B */ + ST.save_curlyx = cur_curlyx; + cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; + PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ - case WHILEM_B_min_fail: /* just failed to match B in a minimal match */ - cur_curlyx = ST.save_curlyx; + case WHILEM_B_min_fail: /* just failed to match B in a minimal match */ + cur_curlyx = ST.save_curlyx; - if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) { - /* Maximum greed exceeded */ - if (cur_curlyx->u.curlyx.count >= REG_INFTY - && ckWARN(WARN_REGEXP) + if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) { + /* Maximum greed exceeded */ + if (cur_curlyx->u.curlyx.count >= REG_INFTY + && ckWARN(WARN_REGEXP) && !reginfo->warned) - { + { reginfo->warned = TRUE; - Perl_warner(aTHX_ packWARN(WARN_REGEXP), - "Complex regular subexpression recursion " - "limit (%d) exceeded", - REG_INFTY - 1); - } - cur_curlyx->u.curlyx.count--; - CACHEsayNO; - } + Perl_warner(aTHX_ packWARN(WARN_REGEXP), + "Complex regular subexpression recursion " + "limit (%d) exceeded", + REG_INFTY - 1); + } + cur_curlyx->u.curlyx.count--; + CACHEsayNO; + } DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "WHILEM: B min fail: trying longer...\n", depth) - ); - /* Try grabbing another A and see if it helps. */ - cur_curlyx->u.curlyx.lastloc = locinput; + ); + /* Try grabbing another A and see if it helps. */ + cur_curlyx->u.curlyx.lastloc = locinput; ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, maxopenparen); - REGCP_SET(ST.lastcp); - PUSH_STATE_GOTO(WHILEM_A_min, - /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS, + REGCP_SET(ST.lastcp); + PUSH_STATE_GOTO(WHILEM_A_min, + /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ #undef ST #define ST st->u.branch - case BRANCHJ: /* /(...|A|...)/ with long next pointer */ - next = scan + ARG(scan); - if (next == scan) - next = NULL; - scan = NEXTOPER(scan); - /* FALLTHROUGH */ - - case BRANCH: /* /(...|A|...)/ */ - scan = NEXTOPER(scan); /* scan now points to inner node */ - ST.lastparen = rex->lastparen; - ST.lastcloseparen = rex->lastcloseparen; - ST.next_branch = next; - REGCP_SET(ST.cp); - - /* Now go into the branch */ - if (has_cutgroup) { - PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput, loceol, + case BRANCHJ: /* /(...|A|...)/ with long next pointer */ + next = scan + ARG(scan); + if (next == scan) + next = NULL; + scan = NEXTOPER(scan); + /* FALLTHROUGH */ + + case BRANCH: /* /(...|A|...)/ */ + scan = NEXTOPER(scan); /* scan now points to inner node */ + ST.lastparen = rex->lastparen; + ST.lastcloseparen = rex->lastcloseparen; + ST.next_branch = next; + REGCP_SET(ST.cp); + + /* Now go into the branch */ + if (has_cutgroup) { + PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput, loceol, script_run_begin); - } else { - PUSH_STATE_GOTO(BRANCH_next, scan, locinput, loceol, + } else { + PUSH_STATE_GOTO(BRANCH_next, scan, locinput, loceol, script_run_begin); - } - NOT_REACHED; /* NOTREACHED */ + } + NOT_REACHED; /* NOTREACHED */ case CUTGROUP: /* /(*THEN)/ */ sv_yes_mark = st->u.mark.mark_name = scan->flags @@ -8853,135 +8853,135 @@ NULL sayYES; NOT_REACHED; /* NOTREACHED */ - case BRANCH_next_fail: /* that branch failed; try the next, if any */ - if (do_cutgroup) { - do_cutgroup = 0; - no_final = 0; - } - REGCP_UNWIND(ST.cp); + case BRANCH_next_fail: /* that branch failed; try the next, if any */ + if (do_cutgroup) { + do_cutgroup = 0; + no_final = 0; + } + REGCP_UNWIND(ST.cp); UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); - scan = ST.next_branch; - /* no more branches? */ - if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) { - DEBUG_EXECUTE_r({ + scan = ST.next_branch; + /* no more branches? */ + if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) { + DEBUG_EXECUTE_r({ Perl_re_exec_indentf( aTHX_ "%sBRANCH failed...%s\n", depth, - PL_colors[4], - PL_colors[5] ); - }); - sayNO_SILENT; + PL_colors[4], + PL_colors[5] ); + }); + sayNO_SILENT; } - continue; /* execute next BRANCH[J] op */ + continue; /* execute next BRANCH[J] op */ /* NOTREACHED */ - case MINMOD: /* next op will be non-greedy, e.g. A*? */ - minmod = 1; - break; + case MINMOD: /* next op will be non-greedy, e.g. A*? */ + minmod = 1; + break; #undef ST #define ST st->u.curlym - case CURLYM: /* /A{m,n}B/ where A is fixed-length */ - - /* This is an optimisation of CURLYX that enables us to push - * only a single backtracking state, no matter how many matches - * there are in {m,n}. It relies on the pattern being constant - * length, with no parens to influence future backrefs - */ - - ST.me = scan; - scan = NEXTOPER(scan) + NODE_STEP_REGNODE; - - ST.lastparen = rex->lastparen; - ST.lastcloseparen = rex->lastcloseparen; - - /* if paren positive, emulate an OPEN/CLOSE around A */ - if (ST.me->flags) { - U32 paren = ST.me->flags; - if (paren > maxopenparen) - maxopenparen = paren; - scan += NEXT_OFF(scan); /* Skip former OPEN. */ - } - ST.A = scan; - ST.B = next; - ST.alen = 0; - ST.count = 0; - ST.minmod = minmod; - minmod = 0; - ST.Binfo.count = -1; - REGCP_SET(ST.cp); - - if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */ - goto curlym_do_B; - - curlym_do_A: /* execute the A in /A{m,n}B/ */ - PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput, loceol, /* match A */ + case CURLYM: /* /A{m,n}B/ where A is fixed-length */ + + /* This is an optimisation of CURLYX that enables us to push + * only a single backtracking state, no matter how many matches + * there are in {m,n}. It relies on the pattern being constant + * length, with no parens to influence future backrefs + */ + + ST.me = scan; + scan = NEXTOPER(scan) + NODE_STEP_REGNODE; + + ST.lastparen = rex->lastparen; + ST.lastcloseparen = rex->lastcloseparen; + + /* if paren positive, emulate an OPEN/CLOSE around A */ + if (ST.me->flags) { + U32 paren = ST.me->flags; + if (paren > maxopenparen) + maxopenparen = paren; + scan += NEXT_OFF(scan); /* Skip former OPEN. */ + } + ST.A = scan; + ST.B = next; + ST.alen = 0; + ST.count = 0; + ST.minmod = minmod; + minmod = 0; + ST.Binfo.count = -1; + REGCP_SET(ST.cp); + + if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */ + goto curlym_do_B; + + curlym_do_A: /* execute the A in /A{m,n}B/ */ + PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput, loceol, /* match A */ script_run_begin); - NOT_REACHED; /* NOTREACHED */ - - case CURLYM_A: /* we've just matched an A */ - ST.count++; - /* after first match, determine A's length: u.curlym.alen */ - if (ST.count == 1) { - if (reginfo->is_utf8_target) { - char *s = st->locinput; - while (s < locinput) { - ST.alen++; - s += UTF8SKIP(s); - } - } - else { - ST.alen = locinput - st->locinput; - } - if (ST.alen == 0) - ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me); - } - DEBUG_EXECUTE_r( + NOT_REACHED; /* NOTREACHED */ + + case CURLYM_A: /* we've just matched an A */ + ST.count++; + /* after first match, determine A's length: u.curlym.alen */ + if (ST.count == 1) { + if (reginfo->is_utf8_target) { + char *s = st->locinput; + while (s < locinput) { + ST.alen++; + s += UTF8SKIP(s); + } + } + else { + ST.alen = locinput - st->locinput; + } + if (ST.alen == 0) + ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me); + } + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "CURLYM now matched %" IVdf " times, len=%" IVdf "...\n", depth, (IV) ST.count, (IV)ST.alen) - ); + ); if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) - goto fake_end; + goto fake_end; - { - I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)); - if ( max == REG_INFTY || ST.count < max ) - goto curlym_do_A; /* try to match another A */ - } - goto curlym_do_B; /* try to match B */ + { + I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)); + if ( max == REG_INFTY || ST.count < max ) + goto curlym_do_A; /* try to match another A */ + } + goto curlym_do_B; /* try to match B */ - case CURLYM_A_fail: /* just failed to match an A */ - REGCP_UNWIND(ST.cp); + case CURLYM_A_fail: /* just failed to match an A */ + REGCP_UNWIND(ST.cp); - if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ + if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ || EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) - sayNO; + sayNO; - curlym_do_B: /* execute the B in /A{m,n}B/ */ - if (ST.Binfo.count < 0) { + curlym_do_B: /* execute the B in /A{m,n}B/ */ + if (ST.Binfo.count < 0) { /* calculate possible match of 1st char following curly */ assert(ST.B); - if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) { - regnode *text_node = ST.B; - if (! HAS_TEXT(text_node)) - FIND_NEXT_IMPT(text_node); - if (PL_regkind[OP(text_node)] == EXACT) { + if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) { + regnode *text_node = ST.B; + if (! HAS_TEXT(text_node)) + FIND_NEXT_IMPT(text_node); + if (PL_regkind[OP(text_node)] == EXACT) { if (! S_setup_EXACTISH_ST(aTHX_ text_node, &ST.Binfo, reginfo)) { sayNO; } - } - } - } + } + } + } - DEBUG_EXECUTE_r( + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "CURLYM trying tail with matches=%" IVdf "...\n", depth, (IV)ST.count) ); - if (! NEXTCHR_IS_EOS && ST.Binfo.count >= 0) { + if (! NEXTCHR_IS_EOS && ST.Binfo.count >= 0) { assert(ST.Binfo.count > 0); /* Do a quick test to hopefully rule out most non-matches */ @@ -9001,84 +9001,84 @@ NULL } } - if (ST.me->flags) { - /* emulate CLOSE: mark current A as captured */ - U32 paren = (U32)ST.me->flags; - if (ST.count) { + if (ST.me->flags) { + /* emulate CLOSE: mark current A as captured */ + U32 paren = (U32)ST.me->flags; + if (ST.count) { CLOSE_CAPTURE(paren, - HOPc(locinput, -ST.alen) - reginfo->strbeg, - locinput - reginfo->strbeg); - } - else - rex->offs[paren].end = -1; + HOPc(locinput, -ST.alen) - reginfo->strbeg, + locinput - reginfo->strbeg); + } + else + rex->offs[paren].end = -1; if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) - { - if (ST.count) - goto fake_end; - else - sayNO; - } - } - - PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput, loceol, /* match B */ + { + if (ST.count) + goto fake_end; + else + sayNO; + } + } + + PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput, loceol, /* match B */ script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ - case CURLYM_B_fail: /* just failed to match a B */ - REGCP_UNWIND(ST.cp); + case CURLYM_B_fail: /* just failed to match a B */ + REGCP_UNWIND(ST.cp); UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); - if (ST.minmod) { - I32 max = ARG2(ST.me); - if (max != REG_INFTY && ST.count == max) - sayNO; - goto curlym_do_A; /* try to match a further A */ - } - /* backtrack one A */ - if (ST.count == ARG1(ST.me) /* min */) - sayNO; - ST.count--; - SET_locinput(HOPc(locinput, -ST.alen)); - goto curlym_do_B; /* try to match B */ + if (ST.minmod) { + I32 max = ARG2(ST.me); + if (max != REG_INFTY && ST.count == max) + sayNO; + goto curlym_do_A; /* try to match a further A */ + } + /* backtrack one A */ + if (ST.count == ARG1(ST.me) /* min */) + sayNO; + ST.count--; + SET_locinput(HOPc(locinput, -ST.alen)); + goto curlym_do_B; /* try to match B */ #undef ST #define ST st->u.curly #define CURLY_SETPAREN(paren, success) \ if (paren) { \ - if (success) { \ + if (success) { \ CLOSE_CAPTURE(paren, HOPc(locinput, -1) - reginfo->strbeg, \ - locinput - reginfo->strbeg); \ - } \ - else { \ - rex->offs[paren].end = -1; \ - rex->lastparen = ST.lastparen; \ - rex->lastcloseparen = ST.lastcloseparen; \ - } \ + locinput - reginfo->strbeg); \ + } \ + else { \ + rex->offs[paren].end = -1; \ + rex->lastparen = ST.lastparen; \ + rex->lastcloseparen = ST.lastcloseparen; \ + } \ } case STAR: /* /A*B/ where A is width 1 char */ - ST.paren = 0; - ST.min = 0; - ST.max = REG_INFTY; - scan = NEXTOPER(scan); - goto repeat; + ST.paren = 0; + ST.min = 0; + ST.max = REG_INFTY; + scan = NEXTOPER(scan); + goto repeat; case PLUS: /* /A+B/ where A is width 1 char */ - ST.paren = 0; - ST.min = 1; - ST.max = REG_INFTY; - scan = NEXTOPER(scan); - goto repeat; + ST.paren = 0; + ST.min = 1; + ST.max = REG_INFTY; + scan = NEXTOPER(scan); + goto repeat; - case CURLYN: /* /(A){m,n}B/ where A is width 1 char */ + case CURLYN: /* /(A){m,n}B/ where A is width 1 char */ ST.paren = scan->flags; /* Which paren to set */ ST.lastparen = rex->lastparen; - ST.lastcloseparen = rex->lastcloseparen; - if (ST.paren > maxopenparen) - maxopenparen = ST.paren; - ST.min = ARG1(scan); /* min to match */ - ST.max = ARG2(scan); /* max to match */ + ST.lastcloseparen = rex->lastcloseparen; + if (ST.paren > maxopenparen) + maxopenparen = ST.paren; + ST.min = ARG1(scan); /* min to match */ + ST.max = ARG2(scan); /* max to match */ scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE); /* handle the single-char capture called as a GOSUB etc */ @@ -9086,124 +9086,124 @@ NULL { char *li = locinput; if (!regrepeat(rex, &li, scan, loceol, reginfo, 1)) - sayNO; + sayNO; SET_locinput(li); goto fake_end; - } - - goto repeat; - - case CURLY: /* /A{m,n}B/ where A is width 1 char */ - ST.paren = 0; - ST.min = ARG1(scan); /* min to match */ - ST.max = ARG2(scan); /* max to match */ - scan = NEXTOPER(scan) + NODE_STEP_REGNODE; - repeat: - /* - * Lookahead to avoid useless match attempts - * when we know what character comes next. - * - * Used to only do .*x and .*?x, but now it allows - * for )'s, ('s and (?{ ... })'s to be in the way - * of the quantifier and the EXACT-like node. -- japhy - */ - - assert(ST.min <= ST.max); + } + + goto repeat; + + case CURLY: /* /A{m,n}B/ where A is width 1 char */ + ST.paren = 0; + ST.min = ARG1(scan); /* min to match */ + ST.max = ARG2(scan); /* max to match */ + scan = NEXTOPER(scan) + NODE_STEP_REGNODE; + repeat: + /* + * Lookahead to avoid useless match attempts + * when we know what character comes next. + * + * Used to only do .*x and .*?x, but now it allows + * for )'s, ('s and (?{ ... })'s to be in the way + * of the quantifier and the EXACT-like node. -- japhy + */ + + assert(ST.min <= ST.max); if (! HAS_TEXT(next) && ! JUMPABLE(next)) { ST.Binfo.count = 0; } else { - regnode *text_node = next; - - if (! HAS_TEXT(text_node)) - FIND_NEXT_IMPT(text_node); - - if (! HAS_TEXT(text_node)) - ST.Binfo.count = 0; - else { - if ( PL_regkind[OP(text_node)] != EXACT ) { - ST.Binfo.count = 0; - } - else { + regnode *text_node = next; + + if (! HAS_TEXT(text_node)) + FIND_NEXT_IMPT(text_node); + + if (! HAS_TEXT(text_node)) + ST.Binfo.count = 0; + else { + if ( PL_regkind[OP(text_node)] != EXACT ) { + ST.Binfo.count = 0; + } + else { if (! S_setup_EXACTISH_ST(aTHX_ text_node, &ST.Binfo, reginfo)) { sayNO; } } - } - } + } + } - ST.A = scan; - ST.B = next; - if (minmod) { + ST.A = scan; + ST.B = next; + if (minmod) { char *li = locinput; - minmod = 0; - if (ST.min && + minmod = 0; + if (ST.min && regrepeat(rex, &li, ST.A, loceol, reginfo, ST.min) < ST.min) - sayNO; + sayNO; SET_locinput(li); - ST.count = ST.min; - REGCP_SET(ST.cp); + ST.count = ST.min; + REGCP_SET(ST.cp); if (ST.Binfo.count <= 0) goto curly_try_B_min; - ST.oldloc = locinput; + ST.oldloc = locinput; - /* set ST.maxpos to the furthest point along the + /* set ST.maxpos to the furthest point along the * string that could possibly match, i.e., that a match could * start at. */ - if (ST.max == REG_INFTY) { - ST.maxpos = loceol - 1; - if (utf8_target) - while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos)) - ST.maxpos--; - } - else if (utf8_target) { - int m = ST.max - ST.min; - for (ST.maxpos = locinput; - m >0 && ST.maxpos < loceol; m--) - ST.maxpos += UTF8SKIP(ST.maxpos); - } - else { - ST.maxpos = locinput + ST.max - ST.min; - if (ST.maxpos >= loceol) - ST.maxpos = loceol - 1; - } - goto curly_try_B_min_known; - - } - else { + if (ST.max == REG_INFTY) { + ST.maxpos = loceol - 1; + if (utf8_target) + while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos)) + ST.maxpos--; + } + else if (utf8_target) { + int m = ST.max - ST.min; + for (ST.maxpos = locinput; + m >0 && ST.maxpos < loceol; m--) + ST.maxpos += UTF8SKIP(ST.maxpos); + } + else { + ST.maxpos = locinput + ST.max - ST.min; + if (ST.maxpos >= loceol) + ST.maxpos = loceol - 1; + } + goto curly_try_B_min_known; + + } + else { /* avoid taking address of locinput, so it can remain * a register var */ char *li = locinput; ST.count = regrepeat(rex, &li, ST.A, loceol, reginfo, ST.max); - if (ST.count < ST.min) - sayNO; + if (ST.count < ST.min) + sayNO; SET_locinput(li); - if ((ST.count > ST.min) - && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL)) - { - /* A{m,n} must come at the end of the string, there's - * no point in backing off ... */ - ST.min = ST.count; - /* ...except that $ and \Z can match before *and* after - newline at the end. Consider "\n\n" =~ /\n+\Z\n/. - We may back off by one in this case. */ - if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS) - ST.min--; - } - REGCP_SET(ST.cp); - goto curly_try_B_max; - } - NOT_REACHED; /* NOTREACHED */ - - case CURLY_B_min_fail: - /* failed to find B in a non-greedy match. */ - - REGCP_UNWIND(ST.cp); + if ((ST.count > ST.min) + && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL)) + { + /* A{m,n} must come at the end of the string, there's + * no point in backing off ... */ + ST.min = ST.count; + /* ...except that $ and \Z can match before *and* after + newline at the end. Consider "\n\n" =~ /\n+\Z\n/. + We may back off by one in this case. */ + if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS) + ST.min--; + } + REGCP_SET(ST.cp); + goto curly_try_B_max; + } + NOT_REACHED; /* NOTREACHED */ + + case CURLY_B_min_fail: + /* failed to find B in a non-greedy match. */ + + REGCP_UNWIND(ST.cp); if (ST.paren) { UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); } @@ -9216,14 +9216,14 @@ NULL } locinput = li; ST.count++; - if (!( ST.count <= ST.max + if (!( ST.count <= ST.max /* count overflow ? */ || (ST.max == REG_INFTY && ST.count > 0)) ) sayNO; } else { - int n; + int n; /* Couldn't or didn't -- move forward. */ ST.oldloc = locinput; if (utf8_target) @@ -9291,8 +9291,8 @@ NULL } while (locinput <= ST.maxpos); } - if (locinput > ST.maxpos) - sayNO; + if (locinput > ST.maxpos) + sayNO; n = (utf8_target) ? utf8_length((U8 *) ST.oldloc, (U8 *) locinput) @@ -9302,27 +9302,27 @@ NULL /* Here is at the beginning of a character that meets the mask * criteria. Need to make sure that some real possibility */ - if (n) { + if (n) { /* In /a{m,n}b/, ST.oldloc is at "a" x m, locinput is * at what may be the beginning of b; check that everything * between oldloc and locinput matches */ char *li = ST.oldloc; - ST.count += n; + ST.count += n; if (regrepeat(rex, &li, ST.A, loceol, reginfo, n) < n) - sayNO; + sayNO; assert(n == REG_INFTY || locinput == li); - } - } + } + } curly_try_B_min: CURLY_SETPAREN(ST.paren, ST.count); PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ curly_try_B_max: - /* a successful greedy match: now try to match B */ + /* a successful greedy match: now try to match B */ if ( ST.Binfo.count <= 0 || ( ST.Binfo.count > 0 && locinput + ST.Binfo.min_length <= loceol @@ -9333,112 +9333,112 @@ NULL script_run_begin); NOT_REACHED; /* NOTREACHED */ } - /* FALLTHROUGH */ + /* FALLTHROUGH */ - case CURLY_B_max_fail: - /* failed to find B in a greedy match */ + case CURLY_B_max_fail: + /* failed to find B in a greedy match */ - REGCP_UNWIND(ST.cp); + REGCP_UNWIND(ST.cp); if (ST.paren) { UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); } - /* back up. */ - if (--ST.count < ST.min) - sayNO; - locinput = HOPc(locinput, -1); - goto curly_try_B_max; + /* back up. */ + if (--ST.count < ST.min) + sayNO; + locinput = HOPc(locinput, -1); + goto curly_try_B_max; #undef ST - case END: /* last op of main pattern */ + case END: /* last op of main pattern */ fake_end: - if (cur_eval) { - /* we've just finished A in /(??{A})B/; now continue with B */ + if (cur_eval) { + /* we've just finished A in /(??{A})B/; now continue with B */ SET_RECURSE_LOCINPUT("FAKE-END[before]", CUR_EVAL.prev_recurse_locinput); - st->u.eval.prev_rex = rex_sv; /* inner */ + st->u.eval.prev_rex = rex_sv; /* inner */ /* Save *all* the positions. */ st->u.eval.cp = regcppush(rex, 0, maxopenparen); rex_sv = CUR_EVAL.prev_rex; - is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); - SET_reg_curpm(rex_sv); - rex = ReANY(rex_sv); - rexi = RXi_GET(rex); + is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); + SET_reg_curpm(rex_sv); + rex = ReANY(rex_sv); + rexi = RXi_GET(rex); st->u.eval.prev_curlyx = cur_curlyx; cur_curlyx = CUR_EVAL.prev_curlyx; - REGCP_SET(st->u.eval.lastcp); + REGCP_SET(st->u.eval.lastcp); - /* Restore parens of the outer rex without popping the - * savestack */ + /* Restore parens of the outer rex without popping the + * savestack */ regcp_restore(rex, CUR_EVAL.lastcp, &maxopenparen); - st->u.eval.prev_eval = cur_eval; + st->u.eval.prev_eval = cur_eval; cur_eval = CUR_EVAL.prev_eval; - DEBUG_EXECUTE_r( + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "END: EVAL trying tail ... (cur_eval=%p)\n", depth, cur_eval);); if ( nochange_depth ) - nochange_depth--; + nochange_depth--; SET_RECURSE_LOCINPUT("FAKE-END[after]", cur_eval->locinput); PUSH_YES_STATE_GOTO(EVAL_postponed_AB, /* match B */ st->u.eval.prev_eval->u.eval.B, locinput, loceol, script_run_begin); - } + } - if (locinput < reginfo->till) { + if (locinput < reginfo->till) { DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sEND: Match possible, but length=%ld is smaller than requested=%ld, failing!%s\n", - PL_colors[4], - (long)(locinput - startpos), - (long)(reginfo->till - startpos), - PL_colors[5])); + PL_colors[4], + (long)(locinput - startpos), + (long)(reginfo->till - startpos), + PL_colors[5])); - sayNO_SILENT; /* Cannot match: too short. */ - } - sayYES; /* Success! */ + sayNO_SILENT; /* Cannot match: too short. */ + } + sayYES; /* Success! */ - case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */ - DEBUG_EXECUTE_r( + case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */ + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "%sSUCCEED: subpattern success...%s\n", depth, PL_colors[4], PL_colors[5])); - sayYES; /* Success! */ + sayYES; /* Success! */ #undef ST #define ST st->u.ifmatch - case SUSPEND: /* (?>A) */ - ST.wanted = 1; - ST.start = locinput; - ST.end = loceol; + case SUSPEND: /* (?>A) */ + ST.wanted = 1; + ST.start = locinput; + ST.end = loceol; ST.count = 1; - goto do_ifmatch; + goto do_ifmatch; - case UNLESSM: /* -ve lookaround: (?!A), or with 'flags', (?next_off + 1; /* next_off repurposed to be lookbehind count, requires non-zero flags */ - if (! scan->flags) { /* 'flags' zero means lookahed */ + if (! scan->flags) { /* 'flags' zero means lookahed */ /* Lookahead starts here and ends at the normal place */ - ST.start = locinput; - ST.end = loceol; + ST.start = locinput; + ST.end = loceol; } - else { + else { PERL_UINT_FAST8_T back_count = scan->flags; - char * s; + char * s; /* Lookbehind can look beyond the current position */ - ST.end = loceol; + ST.end = loceol; /* ... and starts at the first place in the input that is in * the range of the possible start positions */ @@ -9464,23 +9464,23 @@ NULL if (next == scan) next = NULL; break; - } + } - do_ifmatch: - ST.me = scan; - ST.logical = logical; - logical = 0; /* XXX: reset state of logical once it has been saved into ST */ + do_ifmatch: + ST.me = scan; + ST.logical = logical; + logical = 0; /* XXX: reset state of logical once it has been saved into ST */ - /* execute body of (?...A) */ - PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), ST.start, + /* execute body of (?...A) */ + PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), ST.start, ST.end, script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ { bool matched; - case IFMATCH_A_fail: /* body of (?...A) failed */ - if (! ST.logical && ST.count > 1) { + case IFMATCH_A_fail: /* body of (?...A) failed */ + if (! ST.logical && ST.count > 1) { /* It isn't a real failure until we've tried all starting * positions. Move to the next starting position and retry */ @@ -9492,56 +9492,56 @@ NULL } /* Here, all starting positions have been tried. */ - matched = FALSE; - goto ifmatch_done; + matched = FALSE; + goto ifmatch_done; - case IFMATCH_A: /* body of (?...A) succeeded */ - matched = TRUE; + case IFMATCH_A: /* body of (?...A) succeeded */ + matched = TRUE; ifmatch_done: sw = matched == ST.wanted; - if (! ST.logical && !sw) { + if (! ST.logical && !sw) { sayNO; } - if (OP(ST.me) != SUSPEND) { + if (OP(ST.me) != SUSPEND) { /* restore old position except for (?>...) */ - locinput = st->locinput; + locinput = st->locinput; loceol = st->loceol; script_run_begin = st->sr0; - } - scan = ST.me + ARG(ST.me); - if (scan == ST.me) - scan = NULL; - continue; /* execute B */ + } + scan = ST.me + ARG(ST.me); + if (scan == ST.me) + scan = NULL; + continue; /* execute B */ } #undef ST - case LONGJMP: /* alternative with many branches compiles to + case LONGJMP: /* alternative with many branches compiles to * (BRANCHJ; EXACT ...; LONGJMP ) x N */ - next = scan + ARG(scan); - if (next == scan) - next = NULL; - break; + next = scan + ARG(scan); + if (next == scan) + next = NULL; + break; - case COMMIT: /* (*COMMIT) */ - reginfo->cutpoint = loceol; - /* FALLTHROUGH */ + case COMMIT: /* (*COMMIT) */ + reginfo->cutpoint = loceol; + /* FALLTHROUGH */ - case PRUNE: /* (*PRUNE) */ + case PRUNE: /* (*PRUNE) */ if (scan->flags) - sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); - PUSH_STATE_GOTO(COMMIT_next, next, locinput, loceol, + sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); + PUSH_STATE_GOTO(COMMIT_next, next, locinput, loceol, script_run_begin); - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ - case COMMIT_next_fail: - no_final = 1; - /* FALLTHROUGH */ + case COMMIT_next_fail: + no_final = 1; + /* FALLTHROUGH */ sayNO; NOT_REACHED; /* NOTREACHED */ - case OPFAIL: /* (*FAIL) */ + case OPFAIL: /* (*FAIL) */ if (scan->flags) sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); if (logical) { @@ -9553,7 +9553,7 @@ NULL } else { sayNO; } - NOT_REACHED; /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ #define ST st->u.mark case MARKPOINT: /* (*MARK:foo) */ @@ -9575,15 +9575,15 @@ NULL if (popmark && sv_eq(ST.mark_name,popmark)) { if (ST.mark_loc > startpoint) - reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1); + reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1); popmark = NULL; /* we found our mark */ sv_commit = ST.mark_name; DEBUG_EXECUTE_r({ Perl_re_exec_indentf( aTHX_ "%sMARKPOINT: next fail: setting cutpoint to mark:%" SVf "...%s\n", depth, - PL_colors[4], SVfARG(sv_commit), PL_colors[5]); - }); + PL_colors[4], SVfARG(sv_commit), PL_colors[5]); + }); } mark_state = ST.prev_mark; sv_yes_mark = mark_state ? @@ -9619,18 +9619,18 @@ NULL /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */ break; - case SKIP_next_fail: - if (ST.mark_name) { - /* (*CUT:NAME) - Set up to search for the name as we - collapse the stack*/ - popmark = ST.mark_name; - } else { - /* (*CUT) - No name, we cut here.*/ - if (ST.mark_loc > startpoint) - reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1); - /* but we set sv_commit to latest mark_name if there - is one so they can test to see how things lead to this - cut */ + case SKIP_next_fail: + if (ST.mark_name) { + /* (*CUT:NAME) - Set up to search for the name as we + collapse the stack*/ + popmark = ST.mark_name; + } else { + /* (*CUT) - No name, we cut here.*/ + if (ST.mark_loc > startpoint) + reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1); + /* but we set sv_commit to latest mark_name if there + is one so they can test to see how things lead to this + cut */ if (mark_state) sv_commit=mark_state->u.mark.mark_name; } @@ -9646,10 +9646,10 @@ NULL sayNO; break; - default: - PerlIO_printf(Perl_error_log, "%" UVxf " %d\n", - PTR2UV(scan), OP(scan)); - Perl_croak(aTHX_ "regexp memory corruption"); + default: + PerlIO_printf(Perl_error_log, "%" UVxf " %d\n", + PTR2UV(scan), OP(scan)); + Perl_croak(aTHX_ "regexp memory corruption"); /* this is a point to jump to in order to increment * locinput by one character */ @@ -9666,34 +9666,34 @@ NULL locinput++; break; - } /* end switch */ + } /* end switch */ /* switch break jumps here */ - scan = next; /* prepare to execute the next op and ... */ - continue; /* ... jump back to the top, reusing st */ + scan = next; /* prepare to execute the next op and ... */ + continue; /* ... jump back to the top, reusing st */ /* NOTREACHED */ push_yes_state: - /* push a state that backtracks on success */ - st->u.yes.prev_yes_state = yes_state; - yes_state = st; - /* FALLTHROUGH */ + /* push a state that backtracks on success */ + st->u.yes.prev_yes_state = yes_state; + yes_state = st; + /* FALLTHROUGH */ push_state: - /* push a new regex state, then continue at scan */ - { - regmatch_state *newst; + /* push a new regex state, then continue at scan */ + { + regmatch_state *newst; DECLARE_AND_GET_RE_DEBUG_FLAGS; DEBUG_r( /* DEBUG_STACK_r */ if (DEBUG_v_TEST || RE_DEBUG_FLAG(RE_DEBUG_EXTRA_STACK)) { - regmatch_state *cur = st; - regmatch_state *curyes = yes_state; - U32 i; - regmatch_slab *slab = PL_regmatch_slab; + regmatch_state *cur = st; + regmatch_state *curyes = yes_state; + U32 i; + regmatch_slab *slab = PL_regmatch_slab; for (i = 0; i < 3 && i <= depth; cur--,i++) { if (cur < SLAB_FIRST(slab)) { - slab = slab->prev; - cur = SLAB_LAST(slab); + slab = slab->prev; + cur = SLAB_LAST(slab); } Perl_re_exec_indentf( aTHX_ "%4s #%-3d %-10s %s\n", depth, @@ -9702,27 +9702,27 @@ NULL (curyes == cur) ? "yes" : "" ); if (curyes == cur) - curyes = cur->u.yes.prev_yes_state; + curyes = cur->u.yes.prev_yes_state; } } else { DEBUG_STATE_pp("push") }); - depth++; - st->locinput = locinput; - st->loceol = loceol; + depth++; + st->locinput = locinput; + st->loceol = loceol; st->sr0 = script_run_begin; - newst = st+1; - if (newst > SLAB_LAST(PL_regmatch_slab)) - newst = S_push_slab(aTHX); - PL_regmatch_state = newst; + newst = st+1; + if (newst > SLAB_LAST(PL_regmatch_slab)) + newst = S_push_slab(aTHX); + PL_regmatch_state = newst; - locinput = pushinput; + locinput = pushinput; loceol = pusheol; script_run_begin = pushsr0; - st = newst; - continue; + st = newst; + continue; /* NOTREACHED */ - } + } } #ifdef SOLARIS_BAD_OPTIMIZER # undef PL_charclass @@ -9737,64 +9737,64 @@ NULL yes: if (yes_state) { - /* we have successfully completed a subexpression, but we must now - * pop to the state marked by yes_state and continue from there */ - assert(st != yes_state); + /* we have successfully completed a subexpression, but we must now + * pop to the state marked by yes_state and continue from there */ + assert(st != yes_state); #ifdef DEBUGGING - while (st != yes_state) { - st--; - if (st < SLAB_FIRST(PL_regmatch_slab)) { - PL_regmatch_slab = PL_regmatch_slab->prev; - st = SLAB_LAST(PL_regmatch_slab); - } - DEBUG_STATE_r({ - if (no_final) { - DEBUG_STATE_pp("pop (no final)"); - } else { - DEBUG_STATE_pp("pop (yes)"); - } - }); - depth--; - } + while (st != yes_state) { + st--; + if (st < SLAB_FIRST(PL_regmatch_slab)) { + PL_regmatch_slab = PL_regmatch_slab->prev; + st = SLAB_LAST(PL_regmatch_slab); + } + DEBUG_STATE_r({ + if (no_final) { + DEBUG_STATE_pp("pop (no final)"); + } else { + DEBUG_STATE_pp("pop (yes)"); + } + }); + depth--; + } #else - while (yes_state < SLAB_FIRST(PL_regmatch_slab) - || yes_state > SLAB_LAST(PL_regmatch_slab)) - { - /* not in this slab, pop slab */ - depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1); - PL_regmatch_slab = PL_regmatch_slab->prev; - st = SLAB_LAST(PL_regmatch_slab); - } - depth -= (st - yes_state); + while (yes_state < SLAB_FIRST(PL_regmatch_slab) + || yes_state > SLAB_LAST(PL_regmatch_slab)) + { + /* not in this slab, pop slab */ + depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1); + PL_regmatch_slab = PL_regmatch_slab->prev; + st = SLAB_LAST(PL_regmatch_slab); + } + depth -= (st - yes_state); #endif - st = yes_state; - yes_state = st->u.yes.prev_yes_state; - PL_regmatch_state = st; + st = yes_state; + yes_state = st->u.yes.prev_yes_state; + PL_regmatch_state = st; if (no_final) { locinput= st->locinput; loceol= st->loceol; script_run_begin = st->sr0; } - state_num = st->resume_state + no_final; - goto reenter_switch; + state_num = st->resume_state + no_final; + goto reenter_switch; } DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch successful!%s\n", - PL_colors[4], PL_colors[5])); + PL_colors[4], PL_colors[5])); if (reginfo->info_aux_eval) { - /* each successfully executed (?{...}) block does the equivalent of - * local $^R = do {...} - * When popping the save stack, all these locals would be undone; - * bypass this by setting the outermost saved $^R to the latest - * value */ + /* each successfully executed (?{...}) block does the equivalent of + * local $^R = do {...} + * When popping the save stack, all these locals would be undone; + * bypass this by setting the outermost saved $^R to the latest + * value */ /* I dont know if this is needed or works properly now. * see code related to PL_replgv elsewhere in this file. * Yves */ - if (oreplsv != GvSV(PL_replgv)) { - sv_setsv(oreplsv, GvSV(PL_replgv)); + if (oreplsv != GvSV(PL_replgv)) { + sv_setsv(oreplsv, GvSV(PL_replgv)); SvSETMAGIC(oreplsv); } } @@ -9806,7 +9806,7 @@ NULL Perl_re_exec_indentf( aTHX_ "%sfailed...%s\n", depth, PL_colors[4], PL_colors[5]) - ); + ); no_silent: if (no_final) { @@ -9817,25 +9817,25 @@ NULL } } if (depth) { - /* there's a previous state to backtrack to */ - st--; - if (st < SLAB_FIRST(PL_regmatch_slab)) { - PL_regmatch_slab = PL_regmatch_slab->prev; - st = SLAB_LAST(PL_regmatch_slab); - } - PL_regmatch_state = st; - locinput= st->locinput; - loceol= st->loceol; + /* there's a previous state to backtrack to */ + st--; + if (st < SLAB_FIRST(PL_regmatch_slab)) { + PL_regmatch_slab = PL_regmatch_slab->prev; + st = SLAB_LAST(PL_regmatch_slab); + } + PL_regmatch_state = st; + locinput= st->locinput; + loceol= st->loceol; script_run_begin = st->sr0; - DEBUG_STATE_pp("pop"); - depth--; - if (yes_state == st) - yes_state = st->u.yes.prev_yes_state; + DEBUG_STATE_pp("pop"); + depth--; + if (yes_state == st) + yes_state = st->u.yes.prev_yes_state; - state_num = st->resume_state + 1; /* failure = success + 1 */ + state_num = st->resume_state + 1; /* failure = success + 1 */ PERL_ASYNC_CHECK(); - goto reenter_switch; + goto reenter_switch; } result = 0; @@ -9860,9 +9860,9 @@ NULL if (last_pushed_cv) { - dSP; + dSP; /* see "Some notes about MULTICALL" above */ - POP_MULTICALL; + POP_MULTICALL; PERL_UNUSED_VAR(SP); } else @@ -9910,9 +9910,9 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, scan = *startposp; if (max == REG_INFTY) /* This is a special marker to go to the platform's max */ - max = I32_MAX; + max = I32_MAX; else if (! utf8_target && this_eol - scan > max) - this_eol = scan + max; + this_eol = scan + max; /* Here, for the case of a non-UTF-8 target we have adjusted down * to the maximum of how far we should go in it (but leaving it set to the @@ -9939,28 +9939,28 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, switch (OP(p)) { case REG_ANY: - if (utf8_target) { - while (scan < this_eol && hardcount < max && *scan != '\n') { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { + if (utf8_target) { + while (scan < this_eol && hardcount < max && *scan != '\n') { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { scan = (char *) memchr(scan, '\n', this_eol - scan); if (! scan) { scan = this_eol; } - } - break; + } + break; case SANY: if (utf8_target) { - while (scan < this_eol && hardcount < max) { - scan += UTF8SKIP(scan); - hardcount++; - } - } - else - scan = this_eol; - break; + while (scan < this_eol && hardcount < max) { + scan += UTF8SKIP(scan); + hardcount++; + } + } + else + scan = this_eol; + break; case EXACTL: if (utf8_target && UTF8_IS_ABOVE_LATIN1(*scan)) { @@ -10127,7 +10127,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, scan += Binfo.lengths[i]; } - break; + break; } case ANYOFPOSIXL: case ANYOFL: @@ -10137,25 +10137,25 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* FALLTHROUGH */ case ANYOFD: case ANYOF: - if (utf8_target) { - while (hardcount < max + if (utf8_target) { + while (hardcount < max && scan < this_eol - && reginclass(prog, p, (U8*)scan, (U8*) this_eol, utf8_target)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } + && reginclass(prog, p, (U8*)scan, (U8*) this_eol, utf8_target)) + { + scan += UTF8SKIP(scan); + hardcount++; + } + } else if (ANYOF_FLAGS(p) & ~ ANYOF_MATCHES_ALL_ABOVE_BITMAP) { - while (scan < this_eol + while (scan < this_eol && reginclass(prog, p, (U8*)scan, (U8*)scan+1, 0)) - scan++; + scan++; } else { - while (scan < this_eol && ANYOF_BITMAP_TEST(p, *((U8*)scan))) - scan++; - } - break; + while (scan < this_eol && ANYOF_BITMAP_TEST(p, *((U8*)scan))) + scan++; + } + break; case ANYOFM: if (utf8_target && this_eol - scan > max) { @@ -10170,18 +10170,18 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, break; case NANYOFM: - if (utf8_target) { - while ( hardcount < max + if (utf8_target) { + while ( hardcount < max && scan < this_eol - && (*scan & FLAGS(p)) != ARG(p)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } + && (*scan & FLAGS(p)) != ARG(p)) + { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { scan = (char *) find_next_masked((U8 *) scan, (U8 *) this_eol, (U8) ARG(p), FLAGS(p)); - } + } break; case ANYOFH: @@ -10300,23 +10300,23 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case POSIXL: _CHECK_AND_WARN_PROBLEMATIC_LOCALE; - if (! utf8_target) { - while (scan < this_eol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p), + if (! utf8_target) { + while (scan < this_eol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p), *scan))) { - scan++; + scan++; } - } else { - while (hardcount < max && scan < this_eol + } else { + while (hardcount < max && scan < this_eol && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p), (U8 *) scan, (U8 *) this_eol))) { scan += UTF8SKIP(scan); - hardcount++; - } - } - break; + hardcount++; + } + } + break; case POSIXD: if (utf8_target) { @@ -10333,9 +10333,9 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, this_eol = scan + max; } while (scan < this_eol && _generic_isCC_A((U8) *scan, FLAGS(p))) { - scan++; - } - break; + scan++; + } + break; case NPOSIXD: if (utf8_target) { @@ -10354,13 +10354,13 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* The complement of something that matches only ASCII matches all * non-ASCII, plus everything in ASCII that isn't in the class. */ - while (hardcount < max && scan < this_eol + while (hardcount < max && scan < this_eol && ( ! isASCII_utf8_safe(scan, loceol) || ! _generic_isCC_A((U8) *scan, FLAGS(p)))) { scan += UTF8SKIP(scan); - hardcount++; - } + hardcount++; + } } break; @@ -10369,14 +10369,14 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* FALLTHROUGH */ case POSIXU: - if (! utf8_target) { + if (! utf8_target) { while (scan < this_eol && to_complement ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p)))) { scan++; } - } - else { + } + else { utf8_posix: classnum = (_char_class_number) FLAGS(p); switch (classnum) { @@ -10450,26 +10450,26 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } break; } - } + } break; case LNBREAK: if (utf8_target) { - while (hardcount < max && scan < this_eol && + while (hardcount < max && scan < this_eol && (c=is_LNBREAK_utf8_safe(scan, this_eol))) { - scan += c; - hardcount++; - } - } else { + scan += c; + hardcount++; + } + } else { /* LNBREAK can match one or two latin chars, which is ok, but we * have to use hardcount in this situation, and throw away the * adjustment to done before the switch statement */ - while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) { - scan+=c; - hardcount++; - } - } - break; + while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) { + scan+=c; + hardcount++; + } + } + break; default: Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]); @@ -10478,19 +10478,19 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } if (hardcount) - c = hardcount; + c = hardcount; else - c = scan - *startposp; + c = scan - *startposp; *startposp = scan; DEBUG_r({ - DECLARE_AND_GET_RE_DEBUG_FLAGS; - DEBUG_EXECUTE_r({ - SV * const prop = sv_newmortal(); + DECLARE_AND_GET_RE_DEBUG_FLAGS; + DEBUG_EXECUTE_r({ + SV * const prop = sv_newmortal(); regprop(prog, prop, p, reginfo, NULL); Perl_re_exec_indentf( aTHX_ "%s can match %" IVdf " times out of %" IVdf "...\n", depth, SvPVX_const(prop),(IV)c,(IV)max); - }); + }); }); return(c); @@ -10528,8 +10528,8 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const if (! UTF8_IS_INVARIANT(c) && utf8_target) { STRLEN c_len = 0; const U32 utf8n_flags = UTF8_ALLOW_DEFAULT; - c = utf8n_to_uvchr(p, p_end - p, &c_len, utf8n_flags | UTF8_CHECK_ONLY); - if (c_len == (STRLEN)-1) { + c = utf8n_to_uvchr(p, p_end - p, &c_len, utf8n_flags | UTF8_CHECK_ONLY); + if (c_len == (STRLEN)-1) { _force_out_malformed_utf8_message(p, p_end, utf8n_flags, 1 /* 1 means die */ ); @@ -10545,20 +10545,20 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const /* If this character is potentially in the bitmap, check it */ if (c < NUM_ANYOF_CODE_POINTS && ! inRANGE(OP(n), ANYOFH, ANYOFHb)) { - if (ANYOF_BITMAP_TEST(n, c)) - match = TRUE; - else if ((flags + if (ANYOF_BITMAP_TEST(n, c)) + match = TRUE; + else if ((flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER) && OP(n) == ANYOFD - && ! utf8_target - && ! isASCII(c)) - { - match = TRUE; - } - else if (flags & ANYOF_LOCALE_FLAGS) { - if ( (flags & ANYOFL_FOLD) + && ! utf8_target + && ! isASCII(c)) + { + match = TRUE; + } + else if (flags & ANYOF_LOCALE_FLAGS) { + if ( (flags & ANYOFL_FOLD) && c < 256 - && ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) + && ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) { match = TRUE; } @@ -10609,19 +10609,19 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const count++; to_complement ^= 1; } - } - } + } + } } /* If the bitmap didn't (or couldn't) match, and something outside the * bitmap could match, try that. */ if (!match) { - if (c >= NUM_ANYOF_CODE_POINTS + if (c >= NUM_ANYOF_CODE_POINTS && (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP)) { - match = TRUE; /* Everything above the bitmap matches */ - } + match = TRUE; /* Everything above the bitmap matches */ + } /* Here doesn't match everything above the bitmap. If there is * some information available beyond the bitmap, we may find a * match in it. If so, this is most likely because the code point @@ -10632,7 +10632,7 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const * types, because runtime lookup is needed, regardless of the * UTF-8ness of the target string. Finally, under /il, there may * be some matches only possible if the locale is a UTF-8 one. */ - else if ( ARG(n) != ANYOF_ONLY_HAS_BITMAP + else if ( ARG(n) != ANYOF_ONLY_HAS_BITMAP && ( c >= NUM_ANYOF_CODE_POINTS || ( (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP) && ( UNLIKELY(OP(n) != ANYOFD) @@ -10645,7 +10645,7 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const && IN_UTF8_CTYPE_LOCALE))) { SV* only_utf8_locale = NULL; - SV * const definition = + SV * const definition = #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) get_regclass_nonbitmap_data(prog, n, TRUE, 0, &only_utf8_locale, NULL); @@ -10653,16 +10653,16 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const get_re_gclass_nonbitmap_data(prog, n, TRUE, 0, &only_utf8_locale, NULL); #endif - if (definition) { + if (definition) { U8 utf8_buffer[2]; - U8 * utf8_p; - if (utf8_target) { - utf8_p = (U8 *) p; - } else { /* Convert to utf8 */ - utf8_p = utf8_buffer; + U8 * utf8_p; + if (utf8_target) { + utf8_p = (U8 *) p; + } else { /* Convert to utf8 */ + utf8_p = utf8_buffer; append_utf8_from_native_byte(*p, &utf8_p); - utf8_p = utf8_buffer; - } + utf8_p = utf8_buffer; + } /* Turkish locales have these hard-coded rules overriding * normal ones */ @@ -10685,13 +10685,13 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const } } else if (_invlist_contains_cp(definition, c)) { - match = TRUE; + match = TRUE; } - } + } if (! match && only_utf8_locale && IN_UTF8_CTYPE_LOCALE) { match = _invlist_contains_cp(only_utf8_locale, c); } - } + } /* In a Turkic locale under folding, hard-code the I i case pair * matches */ @@ -10701,12 +10701,12 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const && utf8_target) { if (c == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) { - if (ANYOF_BITMAP_TEST(n, 'i')) { + if (ANYOF_BITMAP_TEST(n, 'i')) { match = TRUE; } } else if (c == LATIN_SMALL_LETTER_DOTLESS_I) { - if (ANYOF_BITMAP_TEST(n, 'I')) { + if (ANYOF_BITMAP_TEST(n, 'I')) { match = TRUE; } } @@ -10743,13 +10743,13 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) PERL_ARGS_ASSERT_REGHOP3; if (off >= 0) { - while (off-- && s < lim) { - /* XXX could check well-formedness here */ - U8 *new_s = s + UTF8SKIP(s); + while (off-- && s < lim) { + /* XXX could check well-formedness here */ + U8 *new_s = s + UTF8SKIP(s); if (new_s > lim) /* lim may be in the middle of a long character */ return s; s = new_s; - } + } } else { while (off++ && s > lim) { @@ -10760,9 +10760,9 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) if (! UTF8_IS_START(*s)) { Perl_croak_nocontext("Malformed UTF-8 character (fatal)"); } - } + } /* XXX could check well-formedness here */ - } + } } return s; } @@ -10803,12 +10803,12 @@ S_reghopmaybe3(U8* s, SSize_t off, const U8* const lim) PERL_ARGS_ASSERT_REGHOPMAYBE3; if (off >= 0) { - while (off-- && s < lim) { - /* XXX could check well-formedness here */ - s += UTF8SKIP(s); - } - if (off >= 0) - return NULL; + while (off-- && s < lim) { + /* XXX could check well-formedness here */ + s += UTF8SKIP(s); + } + if (off >= 0) + return NULL; } else { while (off++ && s > lim) { @@ -10819,11 +10819,11 @@ S_reghopmaybe3(U8* s, SSize_t off, const U8* const lim) if (! UTF8_IS_START(*s)) { Perl_croak_nocontext("Malformed UTF-8 character (fatal)"); } - } + } /* XXX could check well-formedness here */ - } - if (off <= 0) - return NULL; + } + if (off <= 0) + return NULL; } return s; } @@ -10986,26 +10986,26 @@ S_to_utf8_substr(pTHX_ regexp *prog) PERL_ARGS_ASSERT_TO_UTF8_SUBSTR; do { - if (prog->substrs->data[i].substr - && !prog->substrs->data[i].utf8_substr) { - SV* const sv = newSVsv(prog->substrs->data[i].substr); - prog->substrs->data[i].utf8_substr = sv; - sv_utf8_upgrade(sv); - if (SvVALID(prog->substrs->data[i].substr)) { - if (SvTAIL(prog->substrs->data[i].substr)) { - /* Trim the trailing \n that fbm_compile added last - time. */ - SvCUR_set(sv, SvCUR(sv) - 1); - /* Whilst this makes the SV technically "invalid" (as its - buffer is no longer followed by "\0") when fbm_compile() - adds the "\n" back, a "\0" is restored. */ - fbm_compile(sv, FBMcf_TAIL); - } else - fbm_compile(sv, 0); - } - if (prog->substrs->data[i].substr == prog->check_substr) - prog->check_utf8 = sv; - } + if (prog->substrs->data[i].substr + && !prog->substrs->data[i].utf8_substr) { + SV* const sv = newSVsv(prog->substrs->data[i].substr); + prog->substrs->data[i].utf8_substr = sv; + sv_utf8_upgrade(sv); + if (SvVALID(prog->substrs->data[i].substr)) { + if (SvTAIL(prog->substrs->data[i].substr)) { + /* Trim the trailing \n that fbm_compile added last + time. */ + SvCUR_set(sv, SvCUR(sv) - 1); + /* Whilst this makes the SV technically "invalid" (as its + buffer is no longer followed by "\0") when fbm_compile() + adds the "\n" back, a "\0" is restored. */ + fbm_compile(sv, FBMcf_TAIL); + } else + fbm_compile(sv, 0); + } + if (prog->substrs->data[i].substr == prog->check_substr) + prog->check_utf8 = sv; + } } while (i--); } @@ -11020,10 +11020,10 @@ S_to_byte_substr(pTHX_ regexp *prog) PERL_ARGS_ASSERT_TO_BYTE_SUBSTR; do { - if (prog->substrs->data[i].utf8_substr - && !prog->substrs->data[i].substr) { - SV* sv = newSVsv(prog->substrs->data[i].utf8_substr); - if (! sv_utf8_downgrade(sv, TRUE)) { + if (prog->substrs->data[i].utf8_substr + && !prog->substrs->data[i].substr) { + SV* sv = newSVsv(prog->substrs->data[i].utf8_substr); + if (! sv_utf8_downgrade(sv, TRUE)) { SvREFCNT_dec_NN(sv); return FALSE; } @@ -11036,10 +11036,10 @@ S_to_byte_substr(pTHX_ regexp *prog) } else fbm_compile(sv, 0); } - prog->substrs->data[i].substr = sv; - if (prog->substrs->data[i].utf8_substr == prog->check_utf8) - prog->check_substr = sv; - } + prog->substrs->data[i].substr = sv; + if (prog->substrs->data[i].utf8_substr == prog->check_utf8) + prog->check_substr = sv; + } } while (i--); return TRUE; diff --git a/regexp.h b/regexp.h index c4210edf8437..731ff1b7ff04 100644 --- a/regexp.h +++ b/regexp.h @@ -209,9 +209,9 @@ typedef struct regexp_engine { void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param); # endif REGEXP* (*op_comp) (pTHX_ SV ** const patternp, int pat_count, - OP *expr, const struct regexp_engine* eng, - REGEXP *old_re, - bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags); + OP *expr, const struct regexp_engine* eng, + REGEXP *old_re, + bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags); } regexp_engine; /* @@ -558,19 +558,19 @@ and check for NULL. #ifdef PERL_ANY_COW # define RXp_MATCH_COPY_FREE(prog) \ - STMT_START {if (RXp_SAVED_COPY(prog)) { \ - SV_CHECK_THINKFIRST_COW_DROP(RXp_SAVED_COPY(prog)); \ - } \ - if (RXp_MATCH_COPIED(prog)) { \ - Safefree(RXp_SUBBEG(prog)); \ - RXp_MATCH_COPIED_off(prog); \ - }} STMT_END + STMT_START {if (RXp_SAVED_COPY(prog)) { \ + SV_CHECK_THINKFIRST_COW_DROP(RXp_SAVED_COPY(prog)); \ + } \ + if (RXp_MATCH_COPIED(prog)) { \ + Safefree(RXp_SUBBEG(prog)); \ + RXp_MATCH_COPIED_off(prog); \ + }} STMT_END #else # define RXp_MATCH_COPY_FREE(prog) \ - STMT_START {if (RXp_MATCH_COPIED(prog)) { \ - Safefree(RXp_SUBBEG(prog)); \ - RXp_MATCH_COPIED_off(prog); \ - }} STMT_END + STMT_START {if (RXp_MATCH_COPIED(prog)) { \ + Safefree(RXp_SUBBEG(prog)); \ + RXp_MATCH_COPIED_off(prog); \ + }} STMT_END #endif #define RX_MATCH_COPY_FREE(rx_sv) RXp_MATCH_COPY_FREE(ReANY(rx_sv)) @@ -610,17 +610,17 @@ and check for NULL. #if defined(PERL_USE_GCC_BRACE_GROUPS) # define ReREFCNT_inc(re) \ ({ \ - /* This is here to generate a casting warning if incorrect. */ \ - REGEXP *const _rerefcnt_inc = (re); \ - assert(SvTYPE(_rerefcnt_inc) == SVt_REGEXP); \ - SvREFCNT_inc(_rerefcnt_inc); \ - _rerefcnt_inc; \ + /* This is here to generate a casting warning if incorrect. */ \ + REGEXP *const _rerefcnt_inc = (re); \ + assert(SvTYPE(_rerefcnt_inc) == SVt_REGEXP); \ + SvREFCNT_inc(_rerefcnt_inc); \ + _rerefcnt_inc; \ }) # define ReREFCNT_dec(re) \ ({ \ - /* This is here to generate a casting warning if incorrect. */ \ - REGEXP *const _rerefcnt_dec = (re); \ - SvREFCNT_dec(_rerefcnt_dec); \ + /* This is here to generate a casting warning if incorrect. */ \ + REGEXP *const _rerefcnt_dec = (re); \ + SvREFCNT_dec(_rerefcnt_dec); \ }) #else # define ReREFCNT_dec(re) SvREFCNT_dec(re) @@ -772,144 +772,144 @@ typedef struct regmatch_state { regmatch_info_aux_eval info_aux_eval; - /* this is a fake union member that matches the first element - * of each member that needs to store positive backtrack - * information */ - struct { - struct regmatch_state *prev_yes_state; - } yes; + /* this is a fake union member that matches the first element + * of each member that needs to store positive backtrack + * information */ + struct { + struct regmatch_state *prev_yes_state; + } yes; /* branchlike members */ /* this is a fake union member that matches the first elements * of each member that needs to behave like a branch */ struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - U32 lastparen; - U32 lastcloseparen; - CHECKPOINT cp; - + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + U32 lastparen; + U32 lastcloseparen; + CHECKPOINT cp; + } branchlike; - - struct { - /* the first elements must match u.branchlike */ - struct regmatch_state *prev_yes_state; - U32 lastparen; - U32 lastcloseparen; - CHECKPOINT cp; - - regnode *next_branch; /* next branch node */ - } branch; - - struct { - /* the first elements must match u.branchlike */ - struct regmatch_state *prev_yes_state; - U32 lastparen; - U32 lastcloseparen; - CHECKPOINT cp; - - U32 accepted; /* how many accepting states left */ - bool longfold;/* saw a fold with a 1->n char mapping */ - U16 *jump; /* positive offsets from me */ - regnode *me; /* Which node am I - needed for jump tries*/ - U8 *firstpos;/* pos in string of first trie match */ - U32 firstchars;/* len in chars of firstpos from start */ - U16 nextword;/* next word to try */ - U16 topword; /* longest accepted word */ - } trie; + + struct { + /* the first elements must match u.branchlike */ + struct regmatch_state *prev_yes_state; + U32 lastparen; + U32 lastcloseparen; + CHECKPOINT cp; + + regnode *next_branch; /* next branch node */ + } branch; + + struct { + /* the first elements must match u.branchlike */ + struct regmatch_state *prev_yes_state; + U32 lastparen; + U32 lastcloseparen; + CHECKPOINT cp; + + U32 accepted; /* how many accepting states left */ + bool longfold;/* saw a fold with a 1->n char mapping */ + U16 *jump; /* positive offsets from me */ + regnode *me; /* Which node am I - needed for jump tries*/ + U8 *firstpos;/* pos in string of first trie match */ + U32 firstchars;/* len in chars of firstpos from start */ + U16 nextword;/* next word to try */ + U16 topword; /* longest accepted word */ + } trie; /* special types - these members are used to store state for special regops like eval, if/then, lookaround and the markpoint state */ - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - struct regmatch_state *prev_curlyx; + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + struct regmatch_state *prev_curlyx; struct regmatch_state *prev_eval; - REGEXP *prev_rex; - CHECKPOINT cp; /* remember current savestack indexes */ - CHECKPOINT lastcp; + REGEXP *prev_rex; + CHECKPOINT cp; /* remember current savestack indexes */ + CHECKPOINT lastcp; U32 close_paren; /* which close bracket is our end (+1) */ - regnode *B; /* the node following us */ + regnode *B; /* the node following us */ char *prev_recurse_locinput; - } eval; + } eval; - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - I32 wanted; - I32 logical; /* saved copy of 'logical' var */ + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + I32 wanted; + I32 logical; /* saved copy of 'logical' var */ U8 count; /* number of beginning positions */ char *start; char *end; - regnode *me; /* the IFMATCH/SUSPEND/UNLESSM node */ - } ifmatch; /* and SUSPEND/UNLESSM */ - - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - struct regmatch_state *prev_mark; - SV* mark_name; - char *mark_loc; - } mark; - - struct { - int val; - } keeper; + regnode *me; /* the IFMATCH/SUSPEND/UNLESSM node */ + } ifmatch; /* and SUSPEND/UNLESSM */ + + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + struct regmatch_state *prev_mark; + SV* mark_name; + char *mark_loc; + } mark; + + struct { + int val; + } keeper; /* quantifiers - these members are used for storing state for the regops used to implement quantifiers */ - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - struct regmatch_state *prev_curlyx; /* previous cur_curlyx */ - regnode *me; /* the CURLYX node */ - regnode *B; /* the B node in /A*B/ */ - CHECKPOINT cp; /* remember current savestack index */ - bool minmod; - int parenfloor;/* how far back to strip paren data */ - - /* these two are modified by WHILEM */ - int count; /* how many instances of A we've matched */ - char *lastloc;/* where previous A matched (0-len detect) */ - } curlyx; - - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - struct regmatch_state *save_curlyx; - CHECKPOINT cp; /* remember current savestack indexes */ - CHECKPOINT lastcp; - char *save_lastloc; /* previous curlyx.lastloc */ - I32 cache_offset; - I32 cache_mask; - } whilem; - - struct { - /* this first element must match u.yes */ - struct regmatch_state *prev_yes_state; - CHECKPOINT cp; - U32 lastparen; - U32 lastcloseparen; - I32 alen; /* length of first-matched A string */ - I32 count; - bool minmod; - regnode *A, *B; /* the nodes corresponding to /A*B/ */ - regnode *me; /* the curlym node */ + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + struct regmatch_state *prev_curlyx; /* previous cur_curlyx */ + regnode *me; /* the CURLYX node */ + regnode *B; /* the B node in /A*B/ */ + CHECKPOINT cp; /* remember current savestack index */ + bool minmod; + int parenfloor;/* how far back to strip paren data */ + + /* these two are modified by WHILEM */ + int count; /* how many instances of A we've matched */ + char *lastloc;/* where previous A matched (0-len detect) */ + } curlyx; + + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + struct regmatch_state *save_curlyx; + CHECKPOINT cp; /* remember current savestack indexes */ + CHECKPOINT lastcp; + char *save_lastloc; /* previous curlyx.lastloc */ + I32 cache_offset; + I32 cache_mask; + } whilem; + + struct { + /* this first element must match u.yes */ + struct regmatch_state *prev_yes_state; + CHECKPOINT cp; + U32 lastparen; + U32 lastcloseparen; + I32 alen; /* length of first-matched A string */ + I32 count; + bool minmod; + regnode *A, *B; /* the nodes corresponding to /A*B/ */ + regnode *me; /* the curlym node */ struct next_matchable_info Binfo; - } curlym; - - struct { - U32 paren; - CHECKPOINT cp; - U32 lastparen; - U32 lastcloseparen; - char *maxpos; /* highest possible point in string to match */ - char *oldloc; /* the previous locinput */ - int count; - int min, max; /* {m,n} */ - regnode *A, *B; /* the nodes corresponding to /A*B/ */ + } curlym; + + struct { + U32 paren; + CHECKPOINT cp; + U32 lastparen; + U32 lastcloseparen; + char *maxpos; /* highest possible point in string to match */ + char *oldloc; /* the previous locinput */ + int count; + int min, max; /* {m,n} */ + regnode *A, *B; /* the nodes corresponding to /A*B/ */ struct next_matchable_info Binfo; - } curly; /* and CURLYN/PLUS/STAR */ + } curly; /* and CURLYN/PLUS/STAR */ } u; } regmatch_state; diff --git a/sv.c b/sv.c index 27c425a54e6f..8cc0c26540ac 100644 --- a/sv.c +++ b/sv.c @@ -118,9 +118,9 @@ */ # define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ - assert((cache)[2] <= (cache)[3]); \ - assert((cache)[3] <= (cache)[1]);} \ - } STMT_END + assert((cache)[2] <= (cache)[3]); \ + assert((cache)[3] <= (cache)[1]);} \ + } STMT_END #else # define ASSERT_UTF8_CACHE(cache) NOOP #endif @@ -187,27 +187,27 @@ following functions (specified as [function that calls visit()] / [function called by visit() for each SV]): sv_report_used() / do_report_used() - dump all remaining SVs (debugging aid) + dump all remaining SVs (debugging aid) sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), - do_clean_named_io_objs(),do_curse() - Attempt to free all objects pointed to by RVs, - try to do the same for all objects indir- - ectly referenced by typeglobs too, and - then do a final sweep, cursing any - objects that remain. Called once from - perl_destruct(), prior to calling sv_clean_all() - below. + do_clean_named_io_objs(),do_curse() + Attempt to free all objects pointed to by RVs, + try to do the same for all objects indir- + ectly referenced by typeglobs too, and + then do a final sweep, cursing any + objects that remain. Called once from + perl_destruct(), prior to calling sv_clean_all() + below. sv_clean_all() / do_clean_all() - SvREFCNT_dec(sv) each remaining SV, possibly - triggering an sv_free(). It also sets the - SVf_BREAK flag on the SV to indicate that the - refcnt has been artificially lowered, and thus - stopping sv_free() from giving spurious warnings - about SVs which unexpectedly have a refcnt - of zero. called repeatedly from perl_destruct() - until there are no SVs left. + SvREFCNT_dec(sv) each remaining SV, possibly + triggering an sv_free(). It also sets the + SVf_BREAK flag on the SV to indicate that the + refcnt has been artificially lowered, and thus + stopping sv_free() from giving spurious warnings + about SVs which unexpectedly have a refcnt + of zero. called repeatedly from perl_destruct() + until there are no SVs left. =head2 Arena allocator API Summary @@ -232,9 +232,9 @@ Public API: #ifdef PERL_MEM_LOG # define MEM_LOG_NEW_SV(sv, file, line, func) \ - Perl_mem_log_new_sv(sv, file, line, func) + Perl_mem_log_new_sv(sv, file, line, func) # define MEM_LOG_DEL_SV(sv, file, line, func) \ - Perl_mem_log_del_sv(sv, file, line, func) + Perl_mem_log_del_sv(sv, file, line, func) #else # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP @@ -242,11 +242,11 @@ Public API: #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ - if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ + if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ } STMT_END # define DEBUG_SV_SERIAL(sv) \ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n", \ - PTR2UV(sv), (long)(sv)->sv_debug_serial)) + PTR2UV(sv), (long)(sv)->sv_debug_serial)) #else # define FREE_SV_DEBUG_FILE(sv) # define DEBUG_SV_SERIAL(sv) NOOP @@ -260,7 +260,7 @@ Public API: # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) */ # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ - PoisonNew(&SvREFCNT(sv), 1, U32) + PoisonNew(&SvREFCNT(sv), 1, U32) #else # define SvARENA_CHAIN(sv) SvANY(sv) # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) @@ -276,24 +276,24 @@ Public API: #define plant_SV(p) \ STMT_START { \ - const U32 old_flags = SvFLAGS(p); \ - MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ - DEBUG_SV_SERIAL(p); \ - FREE_SV_DEBUG_FILE(p); \ - POISON_SV_HEAD(p); \ - SvFLAGS(p) = SVTYPEMASK; \ - if (!(old_flags & SVf_BREAK)) { \ - SvARENA_CHAIN_SET(p, PL_sv_root); \ - PL_sv_root = (p); \ - } \ - --PL_sv_count; \ + const U32 old_flags = SvFLAGS(p); \ + MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ + DEBUG_SV_SERIAL(p); \ + FREE_SV_DEBUG_FILE(p); \ + POISON_SV_HEAD(p); \ + SvFLAGS(p) = SVTYPEMASK; \ + if (!(old_flags & SVf_BREAK)) { \ + SvARENA_CHAIN_SET(p, PL_sv_root); \ + PL_sv_root = (p); \ + } \ + --PL_sv_count; \ } STMT_END #define uproot_SV(p) \ STMT_START { \ - (p) = PL_sv_root; \ - PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ - ++PL_sv_count; \ + (p) = PL_sv_root; \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ + ++PL_sv_count; \ } STMT_END @@ -320,19 +320,19 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) SV* sv; if (PL_sv_root) - uproot_SV(sv); + uproot_SV(sv); else - sv = S_more_sv(aTHX); + sv = S_more_sv(aTHX); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE - ? PL_parser->copline - : PL_curcop - ? CopLINE(PL_curcop) - : 0 - ); + ? PL_parser->copline + : PL_curcop + ? CopLINE(PL_curcop) + : 0 + ); sv->sv_debug_inpad = 0; sv->sv_debug_parent = NULL; sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; @@ -341,7 +341,7 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) MEM_LOG_NEW_SV(sv, file, line, func); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n", - PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); return sv; } @@ -350,14 +350,14 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) #else # define new_SV(p) \ STMT_START { \ - if (PL_sv_root) \ - uproot_SV(p); \ - else \ - (p) = S_more_sv(aTHX); \ - SvANY(p) = 0; \ - SvREFCNT(p) = 1; \ - SvFLAGS(p) = 0; \ - MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = S_more_sv(aTHX); \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ } STMT_END #endif @@ -368,10 +368,10 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) #define del_SV(p) \ STMT_START { \ - if (DEBUG_D_TEST) \ - del_sv(p); \ - else \ - plant_SV(p); \ + if (DEBUG_D_TEST) \ + del_sv(p); \ + else \ + plant_SV(p); \ } STMT_END STATIC void @@ -380,22 +380,22 @@ S_del_sv(pTHX_ SV *p) PERL_ARGS_ASSERT_DEL_SV; if (DEBUG_D_TEST) { - SV* sva; - bool ok = 0; - for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - const SV * const sv = sva + 1; - const SV * const svend = &sva[SvREFCNT(sva)]; - if (p >= sv && p < svend) { - ok = 1; - break; - } - } - if (!ok) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-arena SV: 0x%" UVxf - pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); - return; - } + SV* sva; + bool ok = 0; + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { + const SV * const sv = sva + 1; + const SV * const svend = &sva[SvREFCNT(sva)]; + if (p >= sv && p < svend) { + ok = 1; + break; + } + } + if (!ok) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free non-arena SV: 0x%" UVxf + pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); + return; + } } plant_SV(p); } @@ -438,14 +438,14 @@ S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; while (sv < svend) { - SvARENA_CHAIN_SET(sv, (sv + 1)); + SvARENA_CHAIN_SET(sv, (sv + 1)); #ifdef DEBUGGING - SvREFCNT(sv) = 0; + SvREFCNT(sv) = 0; #endif - /* Must always set typemask because it's always checked in on cleanup - when the arenas are walked looking for objects. */ - SvFLAGS(sv) = SVTYPEMASK; - sv++; + /* Must always set typemask because it's always checked in on cleanup + when the arenas are walked looking for objects. */ + SvFLAGS(sv) = SVTYPEMASK; + sv++; } SvARENA_CHAIN_SET(sv, 0); #ifdef DEBUGGING @@ -466,17 +466,17 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) PERL_ARGS_ASSERT_VISIT; for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - const SV * const svend = &sva[SvREFCNT(sva)]; - SV* sv; - for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != (svtype)SVTYPEMASK - && (sv->sv_flags & mask) == flags - && SvREFCNT(sv)) - { - (*f)(aTHX_ sv); - ++visited; - } - } + const SV * const svend = &sva[SvREFCNT(sva)]; + SV* sv; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != (svtype)SVTYPEMASK + && (sv->sv_flags & mask) == flags + && SvREFCNT(sv)) + { + (*f)(aTHX_ sv); + ++visited; + } + } } return visited; } @@ -489,8 +489,8 @@ static void do_report_used(pTHX_ SV *const sv) { if (SvTYPE(sv) != (svtype)SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "****\n"); - sv_dump(sv); + PerlIO_printf(Perl_debug_log, "****\n"); + sv_dump(sv); } } #endif @@ -520,19 +520,19 @@ do_clean_objs(pTHX_ SV *const ref) { assert (SvROK(ref)); { - SV * const target = SvRV(ref); - if (SvOBJECT(target)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); - if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - } else { - SvROK_off(ref); - SvRV_set(ref, NULL); - SvREFCNT_dec_NN(target); - } - } + SV * const target = SvRV(ref); + if (SvOBJECT(target)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + } else { + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec_NN(target); + } + } } } @@ -547,35 +547,35 @@ do_clean_named_objs(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); if (!GvGP(sv)) - return; + return; /* freeing GP entries may indirectly free the current GV; * hold onto it while we mess with the GP slots */ SvREFCNT_inc(sv); if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob SV object:\n "), sv_dump(obj))); - GvSV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob SV object:\n "), sv_dump(obj))); + GvSV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob AV object:\n "), sv_dump(obj))); - GvAV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob AV object:\n "), sv_dump(obj))); + GvAV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob HV object:\n "), sv_dump(obj))); - GvHV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob HV object:\n "), sv_dump(obj))); + GvHV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob CV object:\n "), sv_dump(obj))); - GvCV_set(sv, NULL); - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob CV object:\n "), sv_dump(obj))); + GvCV_set(sv, NULL); + SvREFCNT_dec_NN(obj); } SvREFCNT_dec_NN(sv); /* undo the inc above */ } @@ -590,14 +590,14 @@ do_clean_named_io_objs(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) - return; + return; SvREFCNT_inc(sv); if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob IO object:\n "), sv_dump(obj))); - GvIOp(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob IO object:\n "), sv_dump(obj))); + GvIOp(sv) = NULL; + SvREFCNT_dec_NN(obj); } SvREFCNT_dec_NN(sv); /* undo the inc above */ } @@ -607,7 +607,7 @@ static void do_curse(pTHX_ SV * const sv) { if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) - return; + return; (void)curse(sv, 0); } @@ -636,11 +636,11 @@ Perl_sv_clean_objs(pTHX) olddef = PL_defoutgv; PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ if (olddef && isGV_with_GP(olddef)) - do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); + do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); olderr = PL_stderrgv; PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ if (olderr && isGV_with_GP(olderr)) - do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); + do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); SvREFCNT_dec(olddef); PL_in_clean_objs = FALSE; } @@ -651,8 +651,8 @@ static void do_clean_all(pTHX_ SV *const sv) { if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { - /* don't clean pid table and strtab */ - return; + /* don't clean pid table and strtab */ + return; } DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; @@ -706,7 +706,7 @@ struct arena_set; therefore likely to be 1 aligned memory page. */ #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ - - 2 * sizeof(int)) / sizeof (struct arena_desc)) + - 2 * sizeof(int)) / sizeof (struct arena_desc)) struct arena_set { struct arena_set* next; @@ -735,33 +735,33 @@ Perl_sv_free_arenas(pTHX) contiguity of the fake ones with the corresponding real ones.) */ for (sva = PL_sv_arenaroot; sva; sva = svanext) { - svanext = MUTABLE_SV(SvANY(sva)); - while (svanext && SvFAKE(svanext)) - svanext = MUTABLE_SV(SvANY(svanext)); + svanext = MUTABLE_SV(SvANY(sva)); + while (svanext && SvFAKE(svanext)) + svanext = MUTABLE_SV(SvANY(svanext)); - if (!SvFAKE(sva)) - Safefree(sva); + if (!SvFAKE(sva)) + Safefree(sva); } { - struct arena_set *aroot = (struct arena_set*) PL_body_arenas; - - while (aroot) { - struct arena_set *current = aroot; - i = aroot->curr; - while (i--) { - assert(aroot->set[i].arena); - Safefree(aroot->set[i].arena); - } - aroot = aroot->next; - Safefree(current); - } + struct arena_set *aroot = (struct arena_set*) PL_body_arenas; + + while (aroot) { + struct arena_set *current = aroot; + i = aroot->curr; + while (i--) { + assert(aroot->set[i].arena); + Safefree(aroot->set[i].arena); + } + aroot = aroot->next; + Safefree(current); + } } PL_body_arenas = 0; i = PERL_ARENA_ROOTS_SIZE; while (i--) - PL_body_roots[i] = 0; + PL_body_roots[i] = 0; PL_sv_arenaroot = 0; PL_sv_root = 0; @@ -936,8 +936,8 @@ ALIGNED_TYPE(XPVIO); for why copying the padding proved to be a bug. */ #define copy_length(type, last_member) \ - STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((const SV *)0))->last_member) + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((const SV *)0))->last_member) static const struct body_details bodies_by_type[] = { /* HEs use this offset for their arena. */ @@ -1033,15 +1033,15 @@ static const struct body_details bodies_by_type[] = { #define new_body_allocated(sv_type) \ (void *)((char *)S_new_body(aTHX_ sv_type) \ - - bodies_by_type[sv_type].offset) + - bodies_by_type[sv_type].offset) /* return a thing to the free list */ #define del_body(thing, root) \ STMT_START { \ - void ** const thing_copy = (void **)thing; \ - *thing_copy = *root; \ - *root = (void*)thing_copy; \ + void ** const thing_copy = (void **)thing; \ + *thing_copy = *root; \ + *root = (void*)thing_copy; \ } STMT_END #ifdef PURIFY @@ -1062,20 +1062,20 @@ static const struct body_details bodies_by_type[] = { #define new_XPVMG() new_body_allocated(SVt_PVMG) #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ - &PL_body_roots[SVt_PVGV]) + &PL_body_roots[SVt_PVGV]) #endif /* PURIFY */ /* no arena for you! */ #define new_NOARENA(details) \ - safemalloc((details)->body_size + (details)->offset) + safemalloc((details)->body_size + (details)->offset) #define new_NOARENAZ(details) \ - safecalloc((details)->body_size + (details)->offset, 1) + safecalloc((details)->body_size + (details)->offset, 1) void * Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, - const size_t arena_size) + const size_t arena_size) { void ** const root = &PL_body_roots[sv_type]; struct arena_desc *adesc; @@ -1088,12 +1088,12 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, static bool done_sanity_check; if (!done_sanity_check) { - unsigned int i = SVt_LAST; + unsigned int i = SVt_LAST; - done_sanity_check = TRUE; + done_sanity_check = TRUE; - while (i--) - assert (bodies_by_type[i].type == i); + while (i--) + assert (bodies_by_type[i].type == i); } #endif @@ -1101,13 +1101,13 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, /* may need new arena-set to hold new arena */ if (!aroot || aroot->curr >= aroot->set_size) { - struct arena_set *newroot; - Newxz(newroot, 1, struct arena_set); - newroot->set_size = ARENAS_PER_SET; - newroot->next = aroot; - aroot = newroot; - PL_body_arenas = (void *) newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); + struct arena_set *newroot; + Newxz(newroot, 1, struct arena_set); + newroot->set_size = ARENAS_PER_SET; + newroot->next = aroot; + aroot = newroot; + PL_body_arenas = (void *) newroot; + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ @@ -1119,7 +1119,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, adesc->size = good_arena_size; adesc->utype = sv_type; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n", - curr, (void*)adesc->arena, (UV)good_arena_size)); + curr, (void*)adesc->arena, (UV)good_arena_size)); start = (char *) adesc->arena; @@ -1130,34 +1130,34 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, /* computed count doesn't reflect the 1st slot reservation */ #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) DEBUG_m(PerlIO_printf(Perl_debug_log, - "arena %p end %p arena-size %d (from %d) type %d " - "size %d ct %d\n", - (void*)start, (void*)end, (int)good_arena_size, - (int)arena_size, sv_type, (int)body_size, - (int)good_arena_size / (int)body_size)); + "arena %p end %p arena-size %d (from %d) type %d " + "size %d ct %d\n", + (void*)start, (void*)end, (int)good_arena_size, + (int)arena_size, sv_type, (int)body_size, + (int)good_arena_size / (int)body_size)); #else DEBUG_m(PerlIO_printf(Perl_debug_log, - "arena %p end %p arena-size %d type %d size %d ct %d\n", - (void*)start, (void*)end, - (int)arena_size, sv_type, (int)body_size, - (int)good_arena_size / (int)body_size)); + "arena %p end %p arena-size %d type %d size %d ct %d\n", + (void*)start, (void*)end, + (int)arena_size, sv_type, (int)body_size, + (int)good_arena_size / (int)body_size)); #endif *root = (void *)start; while (1) { - /* Where the next body would start: */ - char * const next = start + body_size; + /* Where the next body would start: */ + char * const next = start + body_size; - if (next >= end) { - /* This is the last body: */ - assert(next == end); + if (next >= end) { + /* This is the last body: */ + assert(next == end); - *(void **)start = 0; - return *root; - } + *(void **)start = 0; + return *root; + } - *(void**) start = (void *)next; - start = next; + *(void**) start = (void *)next; + start = next; } } @@ -1167,12 +1167,12 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, */ #define new_body_inline(xpv, sv_type) \ STMT_START { \ - void ** const r3wt = &PL_body_roots[sv_type]; \ - xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ - ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ - bodies_by_type[sv_type].body_size,\ - bodies_by_type[sv_type].arena_size)); \ - *(r3wt) = *(void**)(xpv); \ + void ** const r3wt = &PL_body_roots[sv_type]; \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ + bodies_by_type[sv_type].body_size,\ + bodies_by_type[sv_type].arena_size)); \ + *(r3wt) = *(void**)(xpv); \ } STMT_END #ifndef PURIFY @@ -1211,13 +1211,13 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; const struct body_details *old_type_details - = bodies_by_type + old_type; + = bodies_by_type + old_type; SV *referent = NULL; PERL_ARGS_ASSERT_SV_UPGRADE; if (old_type == new_type) - return; + return; /* This clause was purposefully added ahead of the early return above to the shared string hackery for (sort {$a <=> $b} keys %hash), with the @@ -1229,7 +1229,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) purpose. So it's safe to move the early return earlier. */ if (new_type > SVt_PVMG && SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + sv_force_normal_flags(sv, 0); } old_body = SvANY(sv); @@ -1274,49 +1274,49 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) switch (old_type) { case SVt_NULL: - break; + break; case SVt_IV: - if (SvROK(sv)) { - referent = SvRV(sv); - old_type_details = &fake_rv; - if (new_type == SVt_NV) - new_type = SVt_PVNV; - } else { - if (new_type < SVt_PVIV) { - new_type = (new_type == SVt_NV) - ? SVt_PVNV : SVt_PVIV; - } - } - break; + if (SvROK(sv)) { + referent = SvRV(sv); + old_type_details = &fake_rv; + if (new_type == SVt_NV) + new_type = SVt_PVNV; + } else { + if (new_type < SVt_PVIV) { + new_type = (new_type == SVt_NV) + ? SVt_PVNV : SVt_PVIV; + } + } + break; case SVt_NV: - if (new_type < SVt_PVNV) { - new_type = SVt_PVNV; - } - break; + if (new_type < SVt_PVNV) { + new_type = SVt_PVNV; + } + break; case SVt_PV: - assert(new_type > SVt_PV); - STATIC_ASSERT_STMT(SVt_IV < SVt_PV); - STATIC_ASSERT_STMT(SVt_NV < SVt_PV); - break; + assert(new_type > SVt_PV); + STATIC_ASSERT_STMT(SVt_IV < SVt_PV); + STATIC_ASSERT_STMT(SVt_NV < SVt_PV); + break; case SVt_PVIV: - break; + break; case SVt_PVNV: - break; + break; case SVt_PVMG: - /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, - there's no way that it can be safely upgraded, because perl.c - expects to Safefree(SvANY(PL_mess_sv)) */ - assert(sv != PL_mess_sv); - break; + /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, + there's no way that it can be safely upgraded, because perl.c + expects to Safefree(SvANY(PL_mess_sv)) */ + assert(sv != PL_mess_sv); + break; default: - if (UNLIKELY(old_type_details->cant_upgrade)) - Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, - sv_reftype(sv, 0), (UV) old_type, (UV) new_type); + if (UNLIKELY(old_type_details->cant_upgrade)) + Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, + sv_reftype(sv, 0), (UV) old_type, (UV) new_type); } if (UNLIKELY(old_type > new_type)) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)old_type, (int)new_type); + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); new_type_details = bodies_by_type + new_type; @@ -1328,80 +1328,80 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) assert (new_type != SVt_NULL); switch (new_type) { case SVt_IV: - assert(old_type == SVt_NULL); - SET_SVANY_FOR_BODYLESS_IV(sv); - SvIV_set(sv, 0); - return; + assert(old_type == SVt_NULL); + SET_SVANY_FOR_BODYLESS_IV(sv); + SvIV_set(sv, 0); + return; case SVt_NV: - assert(old_type == SVt_NULL); + assert(old_type == SVt_NULL); #if NVSIZE <= IVSIZE - SET_SVANY_FOR_BODYLESS_NV(sv); + SET_SVANY_FOR_BODYLESS_NV(sv); #else - SvANY(sv) = new_XNV(); + SvANY(sv) = new_XNV(); #endif - SvNV_set(sv, 0); - return; + SvNV_set(sv, 0); + return; case SVt_PVHV: case SVt_PVAV: - assert(new_type_details->body_size); + assert(new_type_details->body_size); #ifndef PURIFY - assert(new_type_details->arena); - assert(new_type_details->arena_size); - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_type); - Zero(new_body, new_type_details->body_size, char); - new_body = ((char *)new_body) - new_type_details->offset; + assert(new_type_details->arena); + assert(new_type_details->arena_size); + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type); + Zero(new_body, new_type_details->body_size, char); + new_body = ((char *)new_body) - new_type_details->offset; #else - /* We always allocated the full length item with PURIFY. To do this - we fake things so that arena is false for all 16 types.. */ - new_body = new_NOARENAZ(new_type_details); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + new_body = new_NOARENAZ(new_type_details); #endif - SvANY(sv) = new_body; - if (new_type == SVt_PVAV) { - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - AvREAL_only(sv); - if (old_type_details->body_size) { - AvALLOC(sv) = 0; - } else { - /* It will have been zeroed when the new body was allocated. - Lets not write to it, in case it confuses a write-back - cache. */ - } - } else { - assert(!SvOK(sv)); - SvOK_off(sv); + SvANY(sv) = new_body; + if (new_type == SVt_PVAV) { + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvREAL_only(sv); + if (old_type_details->body_size) { + AvALLOC(sv) = 0; + } else { + /* It will have been zeroed when the new body was allocated. + Lets not write to it, in case it confuses a write-back + cache. */ + } + } else { + assert(!SvOK(sv)); + SvOK_off(sv); #ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(sv); /* key-sharing on by default */ + HvSHAREKEYS_on(sv); /* key-sharing on by default */ #endif /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ - HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; - } - - /* SVt_NULL isn't the only thing upgraded to AV or HV. - The target created by newSVrv also is, and it can have magic. - However, it never has SvPVX set. - */ - if (old_type == SVt_IV) { - assert(!SvROK(sv)); - } else if (old_type >= SVt_PV) { - assert(SvPVX_const(sv) == 0); - } - - if (old_type >= SVt_PVMG) { - SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); - SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); - } else { - sv->sv_u.svu_array = NULL; /* or svu_hash */ - } - break; + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + } + + /* SVt_NULL isn't the only thing upgraded to AV or HV. + The target created by newSVrv also is, and it can have magic. + However, it never has SvPVX set. + */ + if (old_type == SVt_IV) { + assert(!SvROK(sv)); + } else if (old_type >= SVt_PV) { + assert(SvPVX_const(sv) == 0); + } + + if (old_type >= SVt_PVMG) { + SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); + SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + sv->sv_u.svu_array = NULL; /* or svu_hash */ + } + break; case SVt_PVIV: - /* XXX Is this still needed? Was it ever needed? Surely as there is - no route from NV to PVIV, NOK can never be true */ - assert(!SvNOKp(sv)); - assert(!SvNOK(sv)); + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + assert(!SvNOKp(sv)); + assert(!SvNOK(sv)); /* FALLTHROUGH */ case SVt_PVIO: case SVt_PVFM: @@ -1414,84 +1414,84 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) case SVt_PVNV: case SVt_PV: - assert(new_type_details->body_size); - /* We always allocated the full length item with PURIFY. To do this - we fake things so that arena is false for all 16 types.. */ - if(new_type_details->arena) { - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_type); - Zero(new_body, new_type_details->body_size, char); - new_body = ((char *)new_body) - new_type_details->offset; - } else { - new_body = new_NOARENAZ(new_type_details); - } - SvANY(sv) = new_body; - - if (old_type_details->copy) { - /* There is now the potential for an upgrade from something without - an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ - int offset = old_type_details->offset; - int length = old_type_details->copy; - - if (new_type_details->offset > old_type_details->offset) { - const int difference - = new_type_details->offset - old_type_details->offset; - offset += difference; - length -= difference; - } - assert (length >= 0); - - Copy((char *)old_body + offset, (char *)new_body + offset, length, - char); - } + assert(new_type_details->body_size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + if(new_type_details->arena) { + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type); + Zero(new_body, new_type_details->body_size, char); + new_body = ((char *)new_body) - new_type_details->offset; + } else { + new_body = new_NOARENAZ(new_type_details); + } + SvANY(sv) = new_body; + + if (old_type_details->copy) { + /* There is now the potential for an upgrade from something without + an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ + int offset = old_type_details->offset; + int length = old_type_details->copy; + + if (new_type_details->offset > old_type_details->offset) { + const int difference + = new_type_details->offset - old_type_details->offset; + offset += difference; + length -= difference; + } + assert (length >= 0); + + Copy((char *)old_body + offset, (char *)new_body + offset, length, + char); + } #ifndef NV_ZERO_IS_ALLBITS_ZERO - /* If NV 0.0 is stores as all bits 0 then Zero() already creates a - * correct 0.0 for us. Otherwise, if the old body didn't have an - * NV slot, but the new one does, then we need to initialise the - * freshly created NV slot with whatever the correct bit pattern is - * for 0.0 */ - if (old_type_details->zero_nv && !new_type_details->zero_nv - && !isGV_with_GP(sv)) - SvNV_set(sv, 0); + /* If NV 0.0 is stores as all bits 0 then Zero() already creates a + * correct 0.0 for us. Otherwise, if the old body didn't have an + * NV slot, but the new one does, then we need to initialise the + * freshly created NV slot with whatever the correct bit pattern is + * for 0.0 */ + if (old_type_details->zero_nv && !new_type_details->zero_nv + && !isGV_with_GP(sv)) + SvNV_set(sv, 0); #endif - if (UNLIKELY(new_type == SVt_PVIO)) { - IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); + if (UNLIKELY(new_type == SVt_PVIO)) { + IO * const io = MUTABLE_IO(sv); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); - SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a package - name */ + SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a package + name */ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); - hv_clear(PL_stashcache); - - SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); - IoPAGE_LEN(sv) = 60; - } - if (old_type < SVt_PV) { - /* referent will be NULL unless the old type was SVt_IV emulating - SVt_RV */ - sv->sv_u.svu_rv = referent; - } - break; + hv_clear(PL_stashcache); + + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); + IoPAGE_LEN(sv) = 60; + } + if (old_type < SVt_PV) { + /* referent will be NULL unless the old type was SVt_IV emulating + SVt_RV */ + sv->sv_u.svu_rv = referent; + } + break; default: - Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", - (unsigned long)new_type); + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", + (unsigned long)new_type); } /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV, and sometimes SVt_NV */ if (old_type_details->body_size) { #ifdef PURIFY - safefree(old_body); + safefree(old_body); #else - /* Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ - assert(old_type_details->arena); - del_body((void*)((char*)old_body + old_type_details->offset), - &PL_body_roots[old_type]); + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); + del_body((void*)((char*)old_body + old_type_details->offset), + &PL_body_roots[old_type]); #endif } } @@ -1554,21 +1554,21 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) PERL_ARGS_ASSERT_SV_GROW; if (SvROK(sv)) - sv_unref(sv); + sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { - sv_upgrade(sv, SVt_PV); - s = SvPVX_mutable(sv); + sv_upgrade(sv, SVt_PV); + s = SvPVX_mutable(sv); } else if (SvOOK(sv)) { /* pv is offset? */ - sv_backoff(sv); - s = SvPVX_mutable(sv); - if (newlen > SvLEN(sv)) - newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ + sv_backoff(sv); + s = SvPVX_mutable(sv); + if (newlen > SvLEN(sv)) + newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ } else { - if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); - s = SvPVX_mutable(sv); + if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); + s = SvPVX_mutable(sv); } #ifdef PERL_COPY_ON_WRITE @@ -1589,10 +1589,10 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) #endif if (newlen > SvLEN(sv)) { /* need more room? */ - STRLEN minlen = SvCUR(sv); - minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; - if (newlen < minlen) - newlen = minlen; + STRLEN minlen = SvCUR(sv); + minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; + if (newlen < minlen) + newlen = minlen; #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC /* Don't round up on the first allocation, as odds are pretty good that @@ -1603,21 +1603,21 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) newlen = rounded; } #endif - if (SvLEN(sv) && s) { - s = (char*)saferealloc(s, newlen); - } - else { - s = (char*)safemalloc(newlen); - if (SvPVX_const(sv) && SvCUR(sv)) { + if (SvLEN(sv) && s) { + s = (char*)saferealloc(s, newlen); + } + else { + s = (char*)safemalloc(newlen); + if (SvPVX_const(sv) && SvCUR(sv)) { Move(SvPVX_const(sv), s, SvCUR(sv), char); - } - } - SvPV_set(sv, s); + } + } + SvPV_set(sv, s); #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC - /* Do this here, do it once, do it right, and then we will never get - called back into sv_grow() unless there really is some growing - needed. */ - SvLEN_set(sv, Perl_safesysmalloc_size(s)); + /* Do this here, do it once, do it right, and then we will never get + called back into sv_grow() unless there really is some growing + needed. */ + SvLEN_set(sv, Perl_safesysmalloc_size(s)); #else SvLEN_set(sv, newlen); #endif @@ -1646,24 +1646,24 @@ Perl_sv_setiv(pTHX_ SV *const sv, const IV i) switch (SvTYPE(sv)) { case SVt_NULL: case SVt_NV: - sv_upgrade(sv, SVt_IV); - break; + sv_upgrade(sv, SVt_IV); + break; case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; + sv_upgrade(sv, SVt_PVIV); + break; case SVt_PVGV: - if (!isGV_with_GP(sv)) - break; + if (!isGV_with_GP(sv)) + break; /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - /* diag_listed_as: Can't coerce %s to %s in %s */ - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); + /* diag_listed_as: Can't coerce %s to %s in %s */ + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); NOT_REACHED; /* NOTREACHED */ break; default: NOOP; @@ -1750,25 +1750,25 @@ Perl_sv_setnv(pTHX_ SV *const sv, const NV num) switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: - sv_upgrade(sv, SVt_NV); - break; + sv_upgrade(sv, SVt_NV); + break; case SVt_PV: case SVt_PVIV: - sv_upgrade(sv, SVt_PVNV); - break; + sv_upgrade(sv, SVt_PVNV); + break; case SVt_PVGV: - if (!isGV_with_GP(sv)) - break; + if (!isGV_with_GP(sv)) + break; /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - /* diag_listed_as: Can't coerce %s to %s in %s */ - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); + /* diag_listed_as: Can't coerce %s to %s in %s */ + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); NOT_REACHED; /* NOTREACHED */ break; default: NOOP; @@ -1803,56 +1803,56 @@ S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { SV *dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT); } else { - char *d = tmpbuf; - const char * const limit = tmpbuf + tmpbuf_size - 8; - /* each *s can expand to 4 chars + "...\0", - i.e. need room for 8 chars */ - - const char *s = SvPVX_const(sv); - const char * const end = s + SvCUR(sv); - for ( ; s < end && d < limit; s++ ) { - int ch = *s & 0xFF; - if (! isASCII(ch) && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; + char *d = tmpbuf; + const char * const limit = tmpbuf + tmpbuf_size - 8; + /* each *s can expand to 4 chars + "...\0", + i.e. need room for 8 chars */ + + const char *s = SvPVX_const(sv); + const char * const end = s + SvCUR(sv); + for ( ; s < end && d < limit; s++ ) { + int ch = *s & 0xFF; + if (! isASCII(ch) && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; /* Map to ASCII "equivalent" of Latin1 */ - ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (ch == '\0') { - *d++ = '\\'; - *d++ = '0'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (s < end) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; - } - *d = '\0'; - pv = tmpbuf; + ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (s < end) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + pv = tmpbuf; } return pv; @@ -1873,14 +1873,14 @@ S_not_a_number(pTHX_ SV *const sv) pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); if (PL_op) - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - /* diag_listed_as: Argument "%s" isn't numeric%s */ - "Argument \"%s\" isn't numeric in %s", pv, - OP_DESC(PL_op)); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + /* diag_listed_as: Argument "%s" isn't numeric%s */ + "Argument \"%s\" isn't numeric in %s", pv, + OP_DESC(PL_op)); else - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - /* diag_listed_as: Argument "%s" isn't numeric%s */ - "Argument \"%s\" isn't numeric", pv); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + /* diag_listed_as: Argument "%s" isn't numeric%s */ + "Argument \"%s\" isn't numeric", pv); } STATIC void @@ -1917,10 +1917,10 @@ Perl_looks_like_number(pTHX_ SV *const sv) PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; if (SvPOK(sv) || SvPOKp(sv)) { - sbegin = SvPV_nomg_const(sv, len); + sbegin = SvPV_nomg_const(sv, len); } else - return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); numtype = grok_number(sbegin, len, NULL); return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype; } @@ -1931,15 +1931,15 @@ S_glob_2number(pTHX_ GV * const gv) PERL_ARGS_ASSERT_GLOB_2NUMBER; /* We know that all GVs stringify to something that is not-a-number, - so no need to test that. */ + so no need to test that. */ if (ckWARN(WARN_NUMERIC)) { - SV *const buffer = sv_newmortal(); - gv_efullname3(buffer, gv, "*"); - not_a_number(buffer); + SV *const buffer = sv_newmortal(); + gv_efullname3(buffer, gv, "*"); + not_a_number(buffer); } /* We just want something true to return, so that S_sv_2iuv_common - can tail call us and return true. */ + can tail call us and return true. */ return TRUE; } @@ -2030,26 +2030,26 @@ S_glob_2number(pTHX_ GV * const gv) STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *const sv # ifdef DEBUGGING - , I32 numtype + , I32 numtype # endif - ) + ) { PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; PERL_UNUSED_CONTEXT; DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%" UVxf " NV=%" NVgf " inttype=%" UVXf "\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - SvIV_set(sv, IV_MIN); - return IS_NUMBER_UNDERFLOW_IV; + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIV_set(sv, IV_MIN); + return IS_NUMBER_UNDERFLOW_IV; } if (SvNVX(sv) > (NV)UV_MAX) { - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - SvIsUV_on(sv); - SvUV_set(sv, UV_MAX); - return IS_NUMBER_OVERFLOW_UV; + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIsUV_on(sv); + SvUV_set(sv, UV_MAX); + return IS_NUMBER_OVERFLOW_UV; } (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2118,96 +2118,96 @@ S_sv_2iuv_common(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_2IUV_COMMON; if (SvNOKp(sv)) { - /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv - * without also getting a cached IV/UV from it at the same time - * (ie PV->NV conversion should detect loss of accuracy and cache - * IV or UV at same time to avoid this. */ - /* IV-over-UV optimisation - choose to cache IV if possible */ - - if (SvTYPE(sv) == SVt_NV) - sv_upgrade(sv, SVt_PVNV); - - (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ - /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost - certainly cast into the IV range at IV_MAX, whereas the correct - answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary - cases go to UV */ + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. */ + /* IV-over-UV optimisation - choose to cache IV if possible */ + + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); + + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost + certainly cast into the IV range at IV_MAX, whereas the correct + answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary + cases go to UV */ #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - if (Perl_isnan(SvNVX(sv))) { - SvUV_set(sv, 0); - SvIsUV_on(sv); - return FALSE; - } + if (Perl_isnan(SvNVX(sv))) { + SvUV_set(sv, 0); + SvIsUV_on(sv); + return FALSE; + } #endif - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if (SvNVX(sv) == (NV) SvIVX(sv) + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIV_set(sv, I_V(SvNVX(sv))); + if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > - (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ #endif - ) { - if (SvNOK(sv)) - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ - else { - /* scalar has trailing garbage, eg "42a" */ - } - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - - } else { - /* IV not precise. No need to convert from PV, as NV - conversion would already have cached IV if it detected - that PV->IV would be better than PV->NV->IV - flags already correct - don't set public IOK. */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - } - /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, - but the cast (NV)IV_MIN rounds to a the value less (more - negative) than IV_MIN which happens to be equal to SvNVX ?? - Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and - NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and - (NV)UVX == NVX are both true, but the values differ. :-( - Hopefully for 2s complement IV_MIN is something like - 0x8000000000000000 which will be exact. NWC */ - } - else { - SvUV_set(sv, U_V(SvNVX(sv))); - if ( - (SvNVX(sv) == (NV) SvUVX(sv)) + ) { + if (SvNOK(sv)) + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + else { + /* scalar has trailing garbage, eg "42a" */ + } + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } + else { + SvUV_set(sv, U_V(SvNVX(sv))); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV - /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ - /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ #endif - && SvNOK(sv) - ) - SvIOK_on(sv); - SvIsUV_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n", - PTR2UV(sv), - SvUVX(sv), - SvUVX(sv))); - } + && SvNOK(sv) + ) + SvIOK_on(sv); + SvIsUV_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n", + PTR2UV(sv), + SvUVX(sv), + SvUVX(sv))); + } } else if (SvPOKp(sv)) { - UV value; - int numtype; + UV value; + int numtype; const char *s = SvPVX_const(sv); const STRLEN cur = SvCUR(sv); @@ -2224,89 +2224,89 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } } - numtype = grok_number(s, cur, &value); - /* We want to avoid a possible problem when we cache an IV/ a UV which - may be later translated to an NV, and the resulting NV is not - the same as the direct translation of the initial string - (eg 123.456 can shortcut to the IV 123 with atol(), but we must - be careful to ensure that the value with the .456 is around if the - NV value is requested in the future). - - This means that if we cache such an IV/a UV, we need to cache the - NV as well. Moreover, we trade speed for space, and do not - cache the NV if we are sure it's not needed. - */ - - /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer, only upgrade to PVIV */ - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); + numtype = grok_number(s, cur, &value); + /* We want to avoid a possible problem when we cache an IV/ a UV which + may be later translated to an NV, and the resulting NV is not + the same as the direct translation of the initial string + (eg 123.456 can shortcut to the IV 123 with atol(), but we must + be careful to ensure that the value with the .456 is around if the + NV value is requested in the future). + + This means that if we cache such an IV/a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if we are sure it's not needed. + */ + + /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer, only upgrade to PVIV */ + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + } else if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) { if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING))) - not_a_number(sv); + not_a_number(sv); S_sv_setnv(aTHX_ sv, numtype); return FALSE; } - /* If NVs preserve UVs then we only use the UV value if we know that - we aren't going to call atof() below. If NVs don't preserve UVs - then the value returned may have more precision than atof() will - return, even though value isn't perfectly accurate. */ - if ((numtype & (IS_NUMBER_IN_UV + /* If NVs preserve UVs then we only use the UV value if we know that + we aren't going to call atof() below. If NVs don't preserve UVs + then the value returned may have more precision than atof() will + return, even though value isn't perfectly accurate. */ + if ((numtype & (IS_NUMBER_IN_UV #ifdef NV_PRESERVES_UV - | IS_NUMBER_NOT_INT + | IS_NUMBER_NOT_INT #endif - )) == IS_NUMBER_IN_UV) { - /* This won't turn off the public IOK flag if it was set above */ - (void)SvIOKp_on(sv); - - if (!(numtype & IS_NUMBER_NEG)) { - /* positive */; - if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - /* it didn't overflow, and it was positive. */ - SvUV_set(sv, value); - SvIsUV_on(sv); - } - } else { - /* 2s complement assumption */ - if (value <= (UV)IV_MIN) { - SvIV_set(sv, value == (UV)IV_MIN + )) == IS_NUMBER_IN_UV) { + /* This won't turn off the public IOK flag if it was set above */ + (void)SvIOKp_on(sv); + + if (!(numtype & IS_NUMBER_NEG)) { + /* positive */; + if (value <= (UV)IV_MAX) { + SvIV_set(sv, (IV)value); + } else { + /* it didn't overflow, and it was positive. */ + SvUV_set(sv, value); + SvIsUV_on(sv); + } + } else { + /* 2s complement assumption */ + if (value <= (UV)IV_MIN) { + SvIV_set(sv, value == (UV)IV_MIN ? IV_MIN : -(IV)value); - } else { - /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be rare. */ - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNOK_on(sv); - SvIOK_off(sv); - SvIOKp_on(sv); - SvNV_set(sv, -(NV)value); - SvIV_set(sv, IV_MIN); - } - } - } - /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we + } else { + /* Too negative for an IV. This is a double upgrade, but + I'm assuming it will be rare. */ + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNOK_on(sv); + SvIOK_off(sv); + SvIOKp_on(sv); + SvNV_set(sv, -(NV)value); + SvIV_set(sv, IV_MIN); + } + } + } + /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we will be in the previous block to set the IV slot, and the next block to set the NV slot. So no else here. */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - != IS_NUMBER_IN_UV) { - /* It wasn't an (integer that doesn't overflow the UV). */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + != IS_NUMBER_IN_UV) { + /* It wasn't an (integer that doesn't overflow the UV). */ S_sv_setnv(aTHX_ sv, numtype); - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv))); #ifdef NV_PRESERVES_UV (void)SvIOKp_on(sv); @@ -2323,7 +2323,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - NOOP; /* Integer is imprecise. NOK, IOKp */ + NOOP; /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { @@ -2338,10 +2338,10 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ + NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ } } - SvIsUV_on(sv); + SvIsUV_on(sv); } #else /* NV_PRESERVES_UV */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) @@ -2349,7 +2349,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) /* The IV/UV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ - SvNOK_on(sv); + SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2371,7 +2371,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) 0 0 already failed to read UV. 0 1 already failed to read UV. 1 0 you won't get here in this case. IV/UV - slot set, public IOK, Atof() unneeded. + slot set, public IOK, Atof() unneeded. 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ @@ -2383,25 +2383,25 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } } #endif /* NV_PRESERVES_UV */ - /* It might be more code efficient to go through the entire logic above - and conditionally set with SvIOKp_on() rather than SvIOK(), but it - gets complex and potentially buggy, so more programmer efficient - to do it this way, by turning off the public flags: */ - if (!numtype) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); - } + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvIOKp_on() rather than SvIOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); + } } else { - if (isGV_with_GP(sv)) - return glob_2number(MUTABLE_GV(sv)); + if (isGV_with_GP(sv)) + return glob_2number(MUTABLE_GV(sv)); - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - /* Return 0 from the caller. */ - return TRUE; + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); + /* Return 0 from the caller. */ + return TRUE; } return FALSE; } @@ -2422,52 +2422,52 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2IV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV * tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvIV(tmpstr); - } - } - return PTR2IV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV * tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); } if (SvVALID(sv) || isREGEXP(sv)) { /* FBMs use the space for SvIVX and SvNVX for other purposes, so must not let them cache IVs. - In practice they are extremely unlikely to actually get anywhere - accessible by user Perl code - the only way that I'm aware of is when - a constant subroutine which is used as the second argument to index. - - Regexps have no SvIVX and SvNVX fields. - */ - assert(SvPOKp(sv)); - { - UV value; - const char * const ptr = - isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - const int numtype - = grok_number(ptr, SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (numtype & IS_NUMBER_NEG) { - if (value < (UV)IV_MIN) - return -(IV)value; - } else { - if (value < (UV)IV_MAX) - return (IV)value; - } - } + In practice they are extremely unlikely to actually get anywhere + accessible by user Perl code - the only way that I'm aware of is when + a constant subroutine which is used as the second argument to index. + + Regexps have no SvIVX and SvNVX fields. + */ + assert(SvPOKp(sv)); + { + UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + const int numtype + = grok_number(ptr, SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (numtype & IS_NUMBER_NEG) { + if (value < (UV)IV_MIN) + return -(IV)value; + } else { + if (value < (UV)IV_MAX) + return (IV)value; + } + } /* Quite wrong but no good choices. */ if ((numtype & IS_NUMBER_INFINITY)) { @@ -2476,29 +2476,29 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) return 0; /* So wrong. */ } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return I_V(Atof(ptr)); - } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return I_V(Atof(ptr)); + } } if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } } if (!SvIOKp(sv)) { - if (S_sv_2iuv_common(aTHX_ sv)) - return 0; + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n", - PTR2UV(sv),SvIVX(sv))); + PTR2UV(sv),SvIVX(sv))); return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } @@ -2520,39 +2520,39 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2UV_FLAGS; if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvUV(tmpstr); - } - } - return PTR2UV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvUV(tmpstr); + } + } + return PTR2UV(SvRV(sv)); } if (SvVALID(sv) || isREGEXP(sv)) { - /* FBMs use the space for SvIVX and SvNVX for other purposes, and use - the same flag bit as SVf_IVisUV, so must not let them cache IVs. - Regexps have no SvIVX and SvNVX fields. */ - assert(SvPOKp(sv)); - { - UV value; - const char * const ptr = - isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - const int numtype - = grok_number(ptr, SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (!(numtype & IS_NUMBER_NEG)) - return value; - } + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache IVs. + Regexps have no SvIVX and SvNVX fields. */ + assert(SvPOKp(sv)); + { + UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + const int numtype + = grok_number(ptr, SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (!(numtype & IS_NUMBER_NEG)) + return value; + } /* Quite wrong but no good choices. */ if ((numtype & IS_NUMBER_INFINITY)) { @@ -2561,29 +2561,29 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) return 0; /* So wrong. */ } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return U_V(Atof(ptr)); - } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return U_V(Atof(ptr)); + } } if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } } if (!SvIOKp(sv)) { - if (S_sv_2iuv_common(aTHX_ sv)) - return 0; + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n", - PTR2UV(sv),SvUVX(sv))); + PTR2UV(sv),SvUVX(sv))); return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } @@ -2603,129 +2603,129 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2NV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { - /* FBMs use the space for SvIVX and SvNVX for other purposes, and use - the same flag bit as SVf_IVisUV, so must not let them cache NVs. - Regexps have no SvIVX and SvNVX fields. */ - const char *ptr; - if (flags & SV_GMAGIC) - mg_get(sv); - if (SvNOKp(sv)) - return SvNVX(sv); - if (SvPOKp(sv) && !SvIOKp(sv)) { - ptr = SvPVX_const(sv); - if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && - !grok_number(ptr, SvCUR(sv), NULL)) - not_a_number(sv); - return Atof(ptr); - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) - return (NV)SvUVX(sv); - else - return (NV)SvIVX(sv); - } + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache NVs. + Regexps have no SvIVX and SvNVX fields. */ + const char *ptr; + if (flags & SV_GMAGIC) + mg_get(sv); + if (SvNOKp(sv)) + return SvNVX(sv); + if (SvPOKp(sv) && !SvIOKp(sv)) { + ptr = SvPVX_const(sv); + if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && + !grok_number(ptr, SvCUR(sv), NULL)) + not_a_number(sv); + return Atof(ptr); + } + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + return (NV)SvIVX(sv); + } if (SvROK(sv)) { - goto return_rok; - } - assert(SvTYPE(sv) >= SVt_PVMG); - /* This falls through to the report_uninit near the end of the - function. */ + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ } else if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - return_rok: - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); + if (SvROK(sv)) { + return_rok: + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvNV(tmpstr); - } - } - return PTR2NV(SvRV(sv)); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0.0; - } + return SvNV(tmpstr); + } + } + return PTR2NV(SvRV(sv)); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0.0; + } } if (SvTYPE(sv) < SVt_NV) { - /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ - sv_upgrade(sv, SVt_NV); + /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ + sv_upgrade(sv, SVt_NV); CLANG_DIAG_IGNORE_STMT(-Wthread-safety); - DEBUG_c({ + DEBUG_c({ DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, - "0x%" UVxf " num(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv)); + PerlIO_printf(Perl_debug_log, + "0x%" UVxf " num(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv)); RESTORE_LC_NUMERIC(); - }); + }); CLANG_DIAG_RESTORE_STMT; } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); + sv_upgrade(sv, SVt_PVNV); if (SvNOKp(sv)) { return SvNVX(sv); } if (SvIOKp(sv)) { - SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); + SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV - if (SvIOK(sv)) - SvNOK_on(sv); - else - SvNOKp_on(sv); + if (SvIOK(sv)) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else - /* Only set the public NV OK flag if this NV preserves the IV */ - /* Check it's not 0xFFFFFFFFFFFFFFFF */ - if (SvIOK(sv) && - SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) - : (SvIVX(sv) == I_V(SvNVX(sv)))) - SvNOK_on(sv); - else - SvNOKp_on(sv); + /* Only set the public NV OK flag if this NV preserves the IV */ + /* Check it's not 0xFFFFFFFFFFFFFFFF */ + if (SvIOK(sv) && + SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + : (SvIVX(sv) == I_V(SvNVX(sv)))) + SvNOK_on(sv); + else + SvNOKp_on(sv); #endif } else if (SvPOKp(sv)) { - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); + UV value; + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); #ifdef NV_PRESERVES_UV - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); - } else { + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); + } else { S_sv_setnv(aTHX_ sv, numtype); } - if (numtype) - SvNOK_on(sv); - else - SvNOKp_on(sv); + if (numtype) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else - SvNV_set(sv, Atof(SvPVX_const(sv))); - /* Only set the public NV OK flag if this NV preserves the value in - the PV at least as well as an IV/UV would. - Not sure how to do this 100% reliably. */ - /* if that shift count is out of range then Configure's test is - wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == - UV_BITS */ - if (((UV)1 << NV_PRESERVES_UV_BITS) > - U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { - SvNOK_on(sv); /* Definitely small enough to preserve all bits */ - } else if (!(numtype & IS_NUMBER_IN_UV)) { + SvNV_set(sv, Atof(SvPVX_const(sv))); + /* Only set the public NV OK flag if this NV preserves the value in + the PV at least as well as an IV/UV would. + Not sure how to do this 100% reliably. */ + /* if that shift count is out of range then Configure's test is + wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == + UV_BITS */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + SvNOK_on(sv); /* Definitely small enough to preserve all bits */ + } else if (!(numtype & IS_NUMBER_IN_UV)) { /* Can't use strtol etc to convert this string, so don't try. sv_2iv and sv_2uv will use the NV to convert, not the PV. */ SvNOK_on(sv); } else { /* value has been set. It may not be precise. */ - if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) { - /* 2s complement assumption for (UV)IV_MIN */ + if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) { + /* 2s complement assumption for (UV)IV_MIN */ SvNOK_on(sv); /* Integer is too negative. */ } else { SvNOKp_on(sv); @@ -2738,11 +2738,11 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) assert(value != (UV)IV_MIN); SvIV_set(sv, -(IV)value); } else if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - SvUV_set(sv, value); - SvIsUV_on(sv); - } + SvIV_set(sv, (IV)value); + } else { + SvUV_set(sv, value); + SvIsUV_on(sv); + } if (numtype & IS_NUMBER_NOT_INT) { /* I believe that even if the original PV had decimals, @@ -2751,7 +2751,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) flags. NWC, 2000/11/25 */ /* Both already have p flags, so do nothing */ } else { - const NV nv = SvNVX(sv); + const NV nv = SvNVX(sv); /* XXX should this spot have NAN_COMPARE_BROKEN, too? */ if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { @@ -2759,7 +2759,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) } else { /* It had no "." so it must be integer. */ } - SvIOK_on(sv); + SvIOK_on(sv); } else { /* between IV_MAX and NV(UV_MAX). Could be slightly > UV_MAX */ @@ -2767,45 +2767,45 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (numtype & IS_NUMBER_NOT_INT) { /* UV and NV both imprecise. */ } else { - const UV nv_as_uv = U_V(nv); + const UV nv_as_uv = U_V(nv); if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); } - SvIOK_on(sv); + SvIOK_on(sv); } } } } } - /* It might be more code efficient to go through the entire logic above - and conditionally set with SvNOKp_on() rather than SvNOK(), but it - gets complex and potentially buggy, so more programmer efficient - to do it this way, by turning off the public flags: */ - if (!numtype) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvNOKp_on() rather than SvNOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); #endif /* NV_PRESERVES_UV */ } else { - if (isGV_with_GP(sv)) { - glob_2number(MUTABLE_GV(sv)); - return 0.0; - } - - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - assert (SvTYPE(sv) >= SVt_NV); - /* Typically the caller expects that sv_any is not NULL now. */ - /* XXX Ilya implies that this is a bug in callers that assume this - and ideally should be fixed. */ - return 0.0; + if (isGV_with_GP(sv)) { + glob_2number(MUTABLE_GV(sv)); + return 0.0; + } + + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + assert (SvTYPE(sv) >= SVt_NV); + /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ + return 0.0; } CLANG_DIAG_IGNORE_STMT(-Wthread-safety); DEBUG_c({ DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv)); + PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv)); RESTORE_LC_NUMERIC(); }); CLANG_DIAG_RESTORE_STMT; @@ -2828,12 +2828,12 @@ Perl_sv_2num(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_2NUM; if (!SvROK(sv)) - return sv; + return sv; if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLunary(sv, numer_amg); - TAINT_IF(tmpsv && SvTAINTED(tmpsv)); - if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return sv_2num(tmpsv); + SV * const tmpsv = AMG_CALLunary(sv, numer_amg); + TAINT_IF(tmpsv && SvTAINTED(tmpsv)); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return sv_2num(tmpsv); } return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); } @@ -2890,14 +2890,14 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe word_table = (U16*)int2str_table.arr; if (UNLIKELY(is_uv)) - sign = 0; + sign = 0; else if (iv >= 0) { - uv = iv; - sign = 0; + uv = iv; + sign = 0; } else { /* Using 0- here to silence bogus warning from MS VC */ uv = (UV) (0 - (UV) iv); - sign = 1; + sign = 1; } while (uv > 99) { @@ -2982,179 +2982,179 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) PERL_ARGS_ASSERT_SV_2PV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return NULL; - tmpstr = AMG_CALLunary(sv, string_amg); - TAINT_IF(tmpstr && SvTAINTED(tmpstr)); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - /* Unwrap this: */ - /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); - */ - - char *pv; - if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { - if (flags & SV_CONST_RETURN) { - pv = (char *) SvPVX_const(tmpstr); - } else { - pv = (flags & SV_MUTABLE_RETURN) - ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); - } - if (lp) - *lp = SvCUR(tmpstr); - } else { - pv = sv_2pv_flags(tmpstr, lp, flags); - } - if (SvUTF8(tmpstr)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return pv; - } - } - { - STRLEN len; - char *retval; - char *buffer; - SV *const referent = SvRV(sv); - - if (!referent) { - len = 7; - retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_REGEXP && - (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || - amagic_is_enabled(string_amg))) { - REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); - - assert(re); - - /* If the regex is UTF-8 we want the containing scalar to - have an UTF-8 flag too */ - if (RX_UTF8(re)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - - if (lp) - *lp = RX_WRAPLEN(re); - - return RX_WRAPPED(re); - } else { - const char *const typestring = sv_reftype(referent, 0); - const STRLEN typelen = strlen(typestring); - UV addr = PTR2UV(referent); - const char *stashname = NULL; - STRLEN stashnamelen = 0; /* hush, gcc */ - const char *buffer_end; - - if (SvOBJECT(referent)) { - const HEK *const name = HvNAME_HEK(SvSTASH(referent)); - - if (name) { - stashname = HEK_KEY(name); - stashnamelen = HEK_LEN(name); - - if (HEK_UTF8(name)) { - SvUTF8_on(sv); - } else { - SvUTF8_off(sv); - } - } else { - stashname = "__ANON__"; - stashnamelen = 8; - } - len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; - } else { - len = typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; - } - - Newx(buffer, len, char); - buffer_end = retval = buffer + len; - - /* Working backwards */ - *--retval = '\0'; - *--retval = ')'; - do { - *--retval = PL_hexdigit[addr & 15]; - } while (addr >>= 4); - *--retval = 'x'; - *--retval = '0'; - *--retval = '('; - - retval -= typelen; - memcpy(retval, typestring, typelen); - - if (stashname) { - *--retval = '='; - retval -= stashnamelen; - memcpy(retval, stashname, stashnamelen); - } - /* retval may not necessarily have reached the start of the - buffer here. */ - assert (retval >= buffer); - - len = buffer_end - retval - 1; /* -1 for that \0 */ - } - if (lp) - *lp = len; - SAVEFREEPV(buffer); - return retval; - } + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return NULL; + tmpstr = AMG_CALLunary(sv, string_amg); + TAINT_IF(tmpstr && SvTAINTED(tmpstr)); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); + } + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; + } + } + { + STRLEN len; + char *retval; + char *buffer; + SV *const referent = SvRV(sv); + + if (!referent) { + len = 7; + retval = buffer = savepvn("NULLREF", len); + } else if (SvTYPE(referent) == SVt_REGEXP && + (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || + amagic_is_enabled(string_amg))) { + REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); + + assert(re); + + /* If the regex is UTF-8 we want the containing scalar to + have an UTF-8 flag too */ + if (RX_UTF8(re)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + + if (lp) + *lp = RX_WRAPLEN(re); + + return RX_WRAPPED(re); + } else { + const char *const typestring = sv_reftype(referent, 0); + const STRLEN typelen = strlen(typestring); + UV addr = PTR2UV(referent); + const char *stashname = NULL; + STRLEN stashnamelen = 0; /* hush, gcc */ + const char *buffer_end; + + if (SvOBJECT(referent)) { + const HEK *const name = HvNAME_HEK(SvSTASH(referent)); + + if (name) { + stashname = HEK_KEY(name); + stashnamelen = HEK_LEN(name); + + if (HEK_UTF8(name)) { + SvUTF8_on(sv); + } else { + SvUTF8_off(sv); + } + } else { + stashname = "__ANON__"; + stashnamelen = 8; + } + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } + + Newx(buffer, len, char); + buffer_end = retval = buffer + len; + + /* Working backwards */ + *--retval = '\0'; + *--retval = ')'; + do { + *--retval = PL_hexdigit[addr & 15]; + } while (addr >>= 4); + *--retval = 'x'; + *--retval = '0'; + *--retval = '('; + + retval -= typelen; + memcpy(retval, typestring, typelen); + + if (stashname) { + *--retval = '='; + retval -= stashnamelen; + memcpy(retval, stashname, stashnamelen); + } + /* retval may not necessarily have reached the start of the + buffer here. */ + assert (retval >= buffer); + + len = buffer_end - retval - 1; /* -1 for that \0 */ + } + if (lp) + *lp = len; + SAVEFREEPV(buffer); + return retval; + } } if (SvPOKp(sv)) { - if (lp) - *lp = SvCUR(sv); - if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); - if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); - return SvPVX(sv); + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + return SvPVX(sv); } if (SvIOK(sv)) { - /* I'm assuming that if both IV and NV are equally valid then - converting the IV is going to be more efficient */ - const U32 isUIOK = SvIsUV(sv); + /* I'm assuming that if both IV and NV are equally valid then + converting the IV is going to be more efficient */ + const U32 isUIOK = SvIsUV(sv); /* The purpose of this union is to ensure that arr is aligned on a 2 byte boundary, because that is what uiv_2buf() requires */ union { char arr[TYPE_CHARS(UV)]; U16 dummy; } buf; - char *ebuf, *ptr; - STRLEN len; + char *ebuf, *ptr; + STRLEN len; - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); - len = ebuf - ptr; - /* inlined from sv_setpvn */ - s = SvGROW_mutable(sv, len + 1); - Move(ptr, s, len, char); - s += len; - *s = '\0'; + len = ebuf - ptr; + /* inlined from sv_setpvn */ + s = SvGROW_mutable(sv, len + 1); + Move(ptr, s, len, char); + s += len; + *s = '\0'; SvPOK_on(sv); } else if (SvNOK(sv)) { - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - if (SvNVX(sv) == 0.0 + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + if (SvNVX(sv) == 0.0 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - && !Perl_isnan(SvNVX(sv)) + && !Perl_isnan(SvNVX(sv)) #endif - ) { - s = SvGROW_mutable(sv, 2); - *s++ = '0'; - *s = '\0'; - } else { + ) { + s = SvGROW_mutable(sv, 2); + *s++ = '0'; + *s = '\0'; + } else { STRLEN len; STRLEN size = 5; /* "-Inf\0" */ @@ -3217,48 +3217,48 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) RESTORE_ERRNO; } while (*s) s++; - } + } } else if (isGV_with_GP(sv)) { - GV *const gv = MUTABLE_GV(sv); - SV *const buffer = sv_newmortal(); + GV *const gv = MUTABLE_GV(sv); + SV *const buffer = sv_newmortal(); - gv_efullname3(buffer, gv, "*"); + gv_efullname3(buffer, gv, "*"); - assert(SvPOK(buffer)); - if (SvUTF8(buffer)) - SvUTF8_on(sv); + assert(SvPOK(buffer)); + if (SvUTF8(buffer)) + SvUTF8_on(sv); else SvUTF8_off(sv); - if (lp) - *lp = SvCUR(buffer); - return SvPVX(buffer); + if (lp) + *lp = SvCUR(buffer); + return SvPVX(buffer); } else { - if (lp) - *lp = 0; - if (flags & SV_UNDEF_RETURNS_NULL) - return NULL; - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - /* Typically the caller expects that sv_any is not NULL now. */ - if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) - sv_upgrade(sv, SVt_PV); - return (char *)""; + if (lp) + *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + /* Typically the caller expects that sv_any is not NULL now. */ + if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) + sv_upgrade(sv, SVt_PV); + return (char *)""; } { - const STRLEN len = s - SvPVX_const(sv); - if (lp) - *lp = len; - SvCUR_set(sv, len); + const STRLEN len = s - SvPVX_const(sv); + if (lp) + *lp = len; + SvCUR_set(sv, len); } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", - PTR2UV(sv),SvPVX_const(sv))); + PTR2UV(sv),SvPVX_const(sv))); if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); + return (char *)SvPVX_const(sv); if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); + return SvPVX_mutable(sv); return SvPVX(sv); } @@ -3293,9 +3293,9 @@ Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC)); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) - SvUTF8_on(dsv); + SvUTF8_on(dsv); else - SvUTF8_off(dsv); + SvUTF8_off(dsv); } /* @@ -3322,9 +3322,9 @@ Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) || isGV_with_GP(sv) || SvROK(sv)) { - SV *sv2 = sv_newmortal(); - sv_copypv_nomg(sv2,sv); - sv = sv2; + SV *sv2 = sv_newmortal(); + sv_copypv_nomg(sv2,sv); + sv = sv2; } sv_utf8_downgrade_nomg(sv,0); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); @@ -3385,11 +3385,11 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) if(flags & SV_GMAGIC) SvGETMAGIC(sv); if (!SvOK(sv)) - return 0; + return 0; if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLunary(sv, bool__amg); - if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { + if (SvAMAGIC(sv)) { + SV * const tmpsv = AMG_CALLunary(sv, bool__amg); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { bool svb; sv = tmpsv; if(SvGMAGICAL(sv)) { @@ -3413,13 +3413,13 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) } return cBOOL(svb); } - } - assert(SvRV(sv)); - return TRUE; + } + assert(SvRV(sv)); + return TRUE; } if (isREGEXP(sv)) - return - RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); + return + RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); if (SvNOK(sv) && !SvPOK(sv)) return SvNVX(sv) != 0.0; @@ -3474,18 +3474,18 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; if (sv == &PL_sv_undef) - return 0; + return 0; if (!SvPOK_nog(sv)) { - STRLEN len = 0; - if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { - (void) sv_2pv_flags(sv,&len, flags); - if (SvUTF8(sv)) { - if (extra) SvGROW(sv, SvCUR(sv) + extra); - return len; - } - } else { - (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); - } + STRLEN len = 0; + if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { + (void) sv_2pv_flags(sv,&len, flags); + if (SvUTF8(sv)) { + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return len; + } + } else { + (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); + } } /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already @@ -3494,8 +3494,8 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * PVX of a REGEXP should be grown or we should just croak, I don't * know - DAPM */ if (SvUTF8(sv) || isREGEXP(sv)) { - if (extra) SvGROW(sv, SvCUR(sv) + extra); - return SvCUR(sv); + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return SvCUR(sv); } if (SvIsCOW(sv)) { @@ -3506,12 +3506,12 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing byte */ } else { /* Assume Latin-1/EBCDIC */ - /* This function could be much more efficient if we - * had a FLAG in SVs to signal if there are any variant - * chars in the PV. Given that there isn't such a flag - * make the loop as fast as possible. */ - U8 * s = (U8 *) SvPVX_const(sv); - U8 *t = s; + /* This function could be much more efficient if we + * had a FLAG in SVs to signal if there are any variant + * chars in the PV. Given that there isn't such a flag + * make the loop as fast as possible. */ + U8 * s = (U8 *) SvPVX_const(sv); + U8 *t = s; if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) { @@ -3528,9 +3528,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * * Note that the incoming SV may not have a trailing '\0', as certain * code in pp_formline can send us partially built SVs. - * - * There are two main ways to convert. One is to create a new string - * and go through the input starting from the beginning, appending each + * + * There are two main ways to convert. One is to create a new string + * and go through the input starting from the beginning, appending each * converted value onto the new string as we go along. Going this * route, it's probably best to initially allocate enough space in the * string rather than possibly running out of space and having to @@ -3540,13 +3540,13 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * space, one could use the worst case scenario, where every remaining * byte expands to two under UTF-8, or one could parse it and count * exactly how many do expand. - * + * * The other way is to unconditionally parse the remainder of the * string to figure out exactly how big the expanded string will be, * growing if needed. Then start at the end of the string and place * the character there at the end of the unfilled space in the expanded * one, working backwards until reaching 't'. - * + * * The problem with assuming the worst case scenario is that for very * long strings, we could allocate much more memory than actually * needed, which can create performance problems. If we have to parse @@ -3556,7 +3556,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * ASCII platforms, the second method is used exclusively, eliminating * some code that no longer has to be maintained. */ - { + { /* Count the total number of variants there are. We can start * just beyond the first one, which is known to be at 't' */ const Size_t invariant_length = t - s; @@ -3600,21 +3600,21 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr e--; } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* Update pos. We do it at the end rather than during - * the upgrade, to avoid slowing down the common case - * (upgrade without pos). - * pos can be stored as either bytes or characters. Since - * this was previously a byte string we can just turn off - * the bytes flag. */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) { - mg->mg_flags &= ~MGf_BYTES; - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* Update pos. We do it at the end rather than during + * the upgrade, to avoid slowing down the common case + * (upgrade without pos). + * pos can be stored as either bytes or characters. Since + * this was previously a byte string we can just turn off + * the bytes flag. */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + mg->mg_flags &= ~MGf_BYTES; + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } + } } SvUTF8_on(sv); @@ -3652,40 +3652,40 @@ Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 f if (SvPOKp(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { - U8 *s; - STRLEN len; + U8 *s; + STRLEN len; U32 mg_flags = flags & SV_GMAGIC; if (SvIsCOW(sv)) { S_sv_uncow(aTHX_ sv, 0); } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* update pos */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { - mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, - mg_flags|SV_CONST_RETURN); - mg_flags = 0; /* sv_pos_b2u does get magic */ - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - - } - s = (U8 *) SvPV_flags(sv, len, mg_flags); - - if (!utf8_to_bytes(s, &len)) { - if (fail_ok) - return FALSE; - else { - if (PL_op) - Perl_croak(aTHX_ "Wide character in %s", - OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Wide character"); - } - } - SvCUR_set(sv, len); - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* update pos */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { + mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, + mg_flags|SV_CONST_RETURN); + mg_flags = 0; /* sv_pos_b2u does get magic */ + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + + } + s = (U8 *) SvPV_flags(sv, len, mg_flags); + + if (!utf8_to_bytes(s, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Wide character"); + } + } + SvCUR_set(sv, len); + } } SvUTF8_off(sv); return TRUE; @@ -3706,7 +3706,7 @@ Perl_sv_utf8_encode(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_UTF8_ENCODE; if (SvREADONLY(sv)) { - sv_force_normal_flags(sv, 0); + sv_force_normal_flags(sv, 0); } (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); @@ -3732,11 +3732,11 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) if (SvPOKp(sv)) { const U8 *start, *c, *first_variant; - /* The octets may have got themselves encoded - get them back as - * bytes - */ - if (!sv_utf8_downgrade(sv, TRUE)) - return FALSE; + /* The octets may have got themselves encoded - get them back as + * bytes + */ + if (!sv_utf8_downgrade(sv, TRUE)) + return FALSE; /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. @@ -3747,25 +3747,25 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) return FALSE; SvUTF8_on(sv); } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC - after this, clearing pos. Does anything on CPAN - need this? */ - /* adjust pos to the start of a UTF8 char sequence */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) { - I32 pos = mg->mg_len; - if (pos > 0) { - for (c = start + pos; c > start; c--) { - if (UTF8_IS_START(*c)) - break; - } - mg->mg_len = c - start; - } - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC + after this, clearing pos. Does anything on CPAN + need this? */ + /* adjust pos to the start of a UTF8 char sequence */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + I32 pos = mg->mg_len; + if (pos > 0) { + for (c = start + pos; c > start; c--) { + if (UTF8_IS_START(*c)) + break; + } + mg->mg_len = c - start; + } + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } } return TRUE; } @@ -3815,25 +3815,25 @@ S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype) PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) { - const char * const name = GvNAME(ssv); - const STRLEN len = GvNAMELEN(ssv); - { - if (dtype >= SVt_PV) { - SvPV_free(dsv); - SvPV_set(dsv, 0); - SvLEN_set(dsv, 0); - SvCUR_set(dsv, 0); - } - SvUPGRADE(dsv, SVt_PVGV); - (void)SvOK_off(dsv); - isGV_with_GP_on(dsv); - } - GvSTASH(dsv) = GvSTASH(ssv); - if (GvSTASH(dsv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); + const char * const name = GvNAME(ssv); + const STRLEN len = GvNAMELEN(ssv); + { + if (dtype >= SVt_PV) { + SvPV_free(dsv); + SvPV_set(dsv, 0); + SvLEN_set(dsv, 0); + SvCUR_set(dsv, 0); + } + SvUPGRADE(dsv, SVt_PVGV); + (void)SvOK_off(dsv); + isGV_with_GP_on(dsv); + } + GvSTASH(dsv) = GvSTASH(ssv); + if (GvSTASH(dsv)) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); gv_name_set(MUTABLE_GV(dsv), name, len, GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 )); - SvFAKE_on(dsv); /* can coerce to non-glob */ + SvFAKE_on(dsv); /* can coerce to non-glob */ } if(GvGP(MUTABLE_GV(ssv))) { @@ -3899,46 +3899,46 @@ S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype) LEAVE; if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); if (GvIMPORTED(dsv) != GVf_IMPORTED - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) - { - GvIMPORTED_on(dsv); - } + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) + { + GvIMPORTED_on(dsv); + } GvMULTI_on(dsv); if(mro_changes == 2) { if (GvAV((const GV *)ssv)) { - MAGIC *mg; - SV * const sref = (SV *)GvAV((const GV *)dsv); - if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { - if (SvTYPE(mg->mg_obj) != SVt_PVAV) { - AV * const ary = newAV(); - av_push(ary, mg->mg_obj); /* takes the refcount */ - mg->mg_obj = (SV *)ary; - } - av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv)); - } - else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0); + MAGIC *mg; + SV * const sref = (SV *)GvAV((const GV *)dsv); + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv)); + } + else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0); } mro_isa_changed_in(GvSTASH(dsv)); } else if(mro_changes == 3) { - HV * const stash = GvHV(dsv); - if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) - mro_package_moved( - stash, old_stash, - (GV *)dsv, 0 - ); + HV * const stash = GvHV(dsv); + if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) + mro_package_moved( + stash, old_stash, + (GV *)dsv, 0 + ); } else if(mro_changes) mro_method_changed_in(GvSTASH(dsv)); if (GvIO(dsv) && dtype == SVt_PVGV) { - DEBUG_o(Perl_deb(aTHX_ - "glob_assign_glob clearing PL_stashcache\n")); - /* It's a cache. It will rebuild itself quite happily. - It's a lot of effort to work out exactly which key (or keys) - might be invalidated by the creation of the this file handle. - */ - hv_clear(PL_stashcache); + DEBUG_o(Perl_deb(aTHX_ + "glob_assign_glob clearing PL_stashcache\n")); + /* It's a cache. It will rebuild itself quite happily. + It's a lot of effort to work out exactly which key (or keys) + might be invalidated by the creation of the this file handle. + */ + hv_clear(PL_stashcache); } return; } @@ -3956,174 +3956,174 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) PERL_ARGS_ASSERT_GV_SETREF; if (intro) { - GvINTRO_off(dsv); /* one-shot flag */ - GvLINE(dsv) = CopLINE(PL_curcop); - GvEGV(dsv) = MUTABLE_GV(dsv); + GvINTRO_off(dsv); /* one-shot flag */ + GvLINE(dsv) = CopLINE(PL_curcop); + GvEGV(dsv) = MUTABLE_GV(dsv); } GvMULTI_on(dsv); switch (stype) { case SVt_PVCV: - location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */ - import_flag = GVf_IMPORTED_CV; - goto common; + location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */ + import_flag = GVf_IMPORTED_CV; + goto common; case SVt_PVHV: - location = (SV **) &GvHV(dsv); - import_flag = GVf_IMPORTED_HV; - goto common; + location = (SV **) &GvHV(dsv); + import_flag = GVf_IMPORTED_HV; + goto common; case SVt_PVAV: - location = (SV **) &GvAV(dsv); - import_flag = GVf_IMPORTED_AV; - goto common; + location = (SV **) &GvAV(dsv); + import_flag = GVf_IMPORTED_AV; + goto common; case SVt_PVIO: - location = (SV **) &GvIOp(dsv); - goto common; + location = (SV **) &GvIOp(dsv); + goto common; case SVt_PVFM: - location = (SV **) &GvFORM(dsv); - goto common; + location = (SV **) &GvFORM(dsv); + goto common; default: - location = &GvSV(dsv); - import_flag = GVf_IMPORTED_SV; + location = &GvSV(dsv); + import_flag = GVf_IMPORTED_SV; common: - if (intro) { - if (stype == SVt_PVCV) { - /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/ - if (GvCVGEN(dsv)) { - SvREFCNT_dec(GvCV(dsv)); - GvCV_set(dsv, NULL); - GvCVGEN(dsv) = 0; /* Switch off cacheness. */ - } - } - /* SAVEt_GVSLOT takes more room on the savestack and has more - overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs - leave_scope needs access to the GV so it can reset method - caches. We must use SAVEt_GVSLOT whenever the type is - SVt_PVCV, even if the stash is anonymous, as the stash may - gain a name somehow before leave_scope. */ - if (stype == SVt_PVCV) { - /* There is no save_pushptrptrptr. Creating it for this - one call site would be overkill. So inline the ss add - routines here. */ + if (intro) { + if (stype == SVt_PVCV) { + /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/ + if (GvCVGEN(dsv)) { + SvREFCNT_dec(GvCV(dsv)); + GvCV_set(dsv, NULL); + GvCVGEN(dsv) = 0; /* Switch off cacheness. */ + } + } + /* SAVEt_GVSLOT takes more room on the savestack and has more + overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs + leave_scope needs access to the GV so it can reset method + caches. We must use SAVEt_GVSLOT whenever the type is + SVt_PVCV, even if the stash is anonymous, as the stash may + gain a name somehow before leave_scope. */ + if (stype == SVt_PVCV) { + /* There is no save_pushptrptrptr. Creating it for this + one call site would be overkill. So inline the ss add + routines here. */ dSS_ADD; - SS_ADD_PTR(dsv); - SS_ADD_PTR(location); - SS_ADD_PTR(SvREFCNT_inc(*location)); - SS_ADD_UV(SAVEt_GVSLOT); - SS_ADD_END(4); - } - else SAVEGENERICSV(*location); - } - dref = *location; - if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) { - CV* const cv = MUTABLE_CV(*location); - if (cv) { - if (!GvCVGEN((const GV *)dsv) && - (CvROOT(cv) || CvXSUB(cv)) && - /* redundant check that avoids creating the extra SV - most of the time: */ - (CvCONST(cv) || ckWARN(WARN_REDEFINE))) - { - SV * const new_const_sv = - CvCONST((const CV *)sref) - ? cv_const_sv((const CV *)sref) - : NULL; + SS_ADD_PTR(dsv); + SS_ADD_PTR(location); + SS_ADD_PTR(SvREFCNT_inc(*location)); + SS_ADD_UV(SAVEt_GVSLOT); + SS_ADD_END(4); + } + else SAVEGENERICSV(*location); + } + dref = *location; + if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) { + CV* const cv = MUTABLE_CV(*location); + if (cv) { + if (!GvCVGEN((const GV *)dsv) && + (CvROOT(cv) || CvXSUB(cv)) && + /* redundant check that avoids creating the extra SV + most of the time: */ + (CvCONST(cv) || ckWARN(WARN_REDEFINE))) + { + SV * const new_const_sv = + CvCONST((const CV *)sref) + ? cv_const_sv((const CV *)sref) + : NULL; HV * const stash = GvSTASH((const GV *)dsv); - report_redefined_cv( - sv_2mortal( + report_redefined_cv( + sv_2mortal( stash ? Perl_newSVpvf(aTHX_ - "%" HEKf "::%" HEKf, - HEKfARG(HvNAME_HEK(stash)), - HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) + "%" HEKf "::%" HEKf, + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) : Perl_newSVpvf(aTHX_ - "%" HEKf, - HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) - ), - cv, - CvCONST((const CV *)sref) ? &new_const_sv : NULL - ); - } - if (!intro) - cv_ckproto_len_flags(cv, (const GV *)dsv, - SvPOK(sref) ? CvPROTO(sref) : NULL, - SvPOK(sref) ? CvPROTOLEN(sref) : 0, + "%" HEKf, + HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) + ), + cv, + CvCONST((const CV *)sref) ? &new_const_sv : NULL + ); + } + if (!intro) + cv_ckproto_len_flags(cv, (const GV *)dsv, + SvPOK(sref) ? CvPROTO(sref) : NULL, + SvPOK(sref) ? CvPROTOLEN(sref) : 0, SvPOK(sref) ? SvUTF8(sref) : 0); - } - GvCVGEN(dsv) = 0; /* Switch off cacheness. */ - GvASSUMECV_on(dsv); - if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ - if (intro && GvREFCNT(dsv) > 1) { - /* temporary remove extra savestack's ref */ - --GvREFCNT(dsv); - gv_method_changed(dsv); - ++GvREFCNT(dsv); - } - else gv_method_changed(dsv); - } - } - *location = SvREFCNT_inc_simple_NN(sref); - if (import_flag && !(GvFLAGS(dsv) & import_flag) - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) { - GvFLAGS(dsv) |= import_flag; - } - - if (stype == SVt_PVHV) { - const char * const name = GvNAME((GV*)dsv); - const STRLEN len = GvNAMELEN(dsv); - if ( - ( - (len > 1 && name[len-2] == ':' && name[len-1] == ':') - || (len == 1 && name[0] == ':') - ) - && (!dref || HvENAME_get(dref)) - ) { - mro_package_moved( - (HV *)sref, (HV *)dref, - (GV *)dsv, 0 - ); - } - } - else if ( - stype == SVt_PVAV && sref != dref - && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA") - /* The stash may have been detached from the symbol table, so - check its name before doing anything. */ - && GvSTASH(dsv) && HvENAME(GvSTASH(dsv)) - ) { - MAGIC *mg; - MAGIC * const omg = dref && SvSMAGICAL(dref) - ? mg_find(dref, PERL_MAGIC_isa) - : NULL; - if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { - if (SvTYPE(mg->mg_obj) != SVt_PVAV) { - AV * const ary = newAV(); - av_push(ary, mg->mg_obj); /* takes the refcount */ - mg->mg_obj = (SV *)ary; - } - if (omg) { - if (SvTYPE(omg->mg_obj) == SVt_PVAV) { - SV **svp = AvARRAY((AV *)omg->mg_obj); - I32 items = AvFILLp((AV *)omg->mg_obj) + 1; - while (items--) - av_push( - (AV *)mg->mg_obj, - SvREFCNT_inc_simple_NN(*svp++) - ); - } - else - av_push( - (AV *)mg->mg_obj, - SvREFCNT_inc_simple_NN(omg->mg_obj) - ); - } - else - av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv)); - } - else - { + } + GvCVGEN(dsv) = 0; /* Switch off cacheness. */ + GvASSUMECV_on(dsv); + if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if (intro && GvREFCNT(dsv) > 1) { + /* temporary remove extra savestack's ref */ + --GvREFCNT(dsv); + gv_method_changed(dsv); + ++GvREFCNT(dsv); + } + else gv_method_changed(dsv); + } + } + *location = SvREFCNT_inc_simple_NN(sref); + if (import_flag && !(GvFLAGS(dsv) & import_flag) + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) { + GvFLAGS(dsv) |= import_flag; + } + + if (stype == SVt_PVHV) { + const char * const name = GvNAME((GV*)dsv); + const STRLEN len = GvNAMELEN(dsv); + if ( + ( + (len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':') + ) + && (!dref || HvENAME_get(dref)) + ) { + mro_package_moved( + (HV *)sref, (HV *)dref, + (GV *)dsv, 0 + ); + } + } + else if ( + stype == SVt_PVAV && sref != dref + && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA") + /* The stash may have been detached from the symbol table, so + check its name before doing anything. */ + && GvSTASH(dsv) && HvENAME(GvSTASH(dsv)) + ) { + MAGIC *mg; + MAGIC * const omg = dref && SvSMAGICAL(dref) + ? mg_find(dref, PERL_MAGIC_isa) + : NULL; + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + if (omg) { + if (SvTYPE(omg->mg_obj) == SVt_PVAV) { + SV **svp = AvARRAY((AV *)omg->mg_obj); + I32 items = AvFILLp((AV *)omg->mg_obj) + 1; + while (items--) + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(*svp++) + ); + } + else + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(omg->mg_obj) + ); + } + else + av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv)); + } + else + { SSize_t i; - sv_magic( - sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0 - ); + sv_magic( + sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0 + ); for (i = 0; i <= AvFILL(sref); ++i) { SV **elem = av_fetch ((AV*)sref, i, 0); if (elem) { @@ -4132,16 +4132,16 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) ); } } - mg = mg_find(sref, PERL_MAGIC_isa); - } - /* Since the *ISA assignment could have affected more than - one stash, don't call mro_isa_changed_in directly, but let - magic_clearisa do it for us, as it already has the logic for - dealing with globs vs arrays of globs. */ - assert(mg); - Perl_magic_clearisa(aTHX_ NULL, mg); - } - else if (stype == SVt_PVIO) { + mg = mg_find(sref, PERL_MAGIC_isa); + } + /* Since the *ISA assignment could have affected more than + one stash, don't call mro_isa_changed_in directly, but let + magic_clearisa do it for us, as it already has the logic for + dealing with globs vs arrays of globs. */ + assert(mg); + Perl_magic_clearisa(aTHX_ NULL, mg); + } + else if (stype == SVt_PVIO) { DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n")); /* It's a cache. It will rebuild itself quite happily. It's a lot of effort to work out exactly which key (or keys) @@ -4149,11 +4149,11 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) */ hv_clear(PL_stashcache); } - break; + break; } if (!intro) SvREFCNT_dec(dref); if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); return; } @@ -4171,27 +4171,27 @@ void Perl_sv_buf_to_ro(pTHX_ SV *sv) { struct perl_memory_debug_header * const header = - (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); const MEM_SIZE len = header->size; PERL_ARGS_ASSERT_SV_BUF_TO_RO; # ifdef PERL_TRACK_MEMPOOL if (!header->readonly) header->readonly = 1; # endif if (mprotect(header, len, PROT_READ)) - Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", - header, len, errno); + Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", + header, len, errno); } static void S_sv_buf_to_rw(pTHX_ SV *sv) { struct perl_memory_debug_header * const header = - (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); const MEM_SIZE len = header->size; PERL_ARGS_ASSERT_SV_BUF_TO_RW; if (mprotect(header, len, PROT_READ|PROT_WRITE)) - Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", - header, len, errno); + Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", + header, len, errno); # ifdef PERL_TRACK_MEMPOOL header->readonly = 0; # endif @@ -4213,10 +4213,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) PERL_ARGS_ASSERT_SV_SETSV_FLAGS; if (UNLIKELY( ssv == dsv )) - return; + return; if (UNLIKELY( !ssv )) - ssv = &PL_sv_undef; + ssv = &PL_sv_undef; stype = SvTYPE(ssv); dtype = SvTYPE(dsv); @@ -4297,126 +4297,126 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) switch (stype) { case SVt_NULL: undef_sstr: - if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) { - (void)SvOK_off(dsv); - return; - } - break; + if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) { + (void)SvOK_off(dsv); + return; + } + break; case SVt_IV: - if (SvIOK(ssv)) { - switch (dtype) { - case SVt_NULL: - /* For performance, we inline promoting to type SVt_IV. */ - /* We're starting from SVt_NULL, so provided that define is - * actual 0, we don't have to unset any SV type flags - * to promote to SVt_IV. */ - STATIC_ASSERT_STMT(SVt_NULL == 0); - SET_SVANY_FOR_BODYLESS_IV(dsv); - SvFLAGS(dsv) |= SVt_IV; - break; - case SVt_NV: - case SVt_PV: - sv_upgrade(dsv, SVt_PVIV); - break; - case SVt_PVGV: - case SVt_PVLV: - goto end_of_first_switch; - } - (void)SvIOK_only(dsv); - SvIV_set(dsv, SvIVX(ssv)); - if (SvIsUV(ssv)) - SvIsUV_on(dsv); - /* SvTAINTED can only be true if the SV has taint magic, which in - turn means that the SV type is PVMG (or greater). This is the - case statement for SVt_IV, so this cannot be true (whatever gcov - may say). */ - assert(!SvTAINTED(ssv)); - return; - } - if (!SvROK(ssv)) - goto undef_sstr; - if (dtype < SVt_PV && dtype != SVt_IV) - sv_upgrade(dsv, SVt_IV); - break; + if (SvIOK(ssv)) { + switch (dtype) { + case SVt_NULL: + /* For performance, we inline promoting to type SVt_IV. */ + /* We're starting from SVt_NULL, so provided that define is + * actual 0, we don't have to unset any SV type flags + * to promote to SVt_IV. */ + STATIC_ASSERT_STMT(SVt_NULL == 0); + SET_SVANY_FOR_BODYLESS_IV(dsv); + SvFLAGS(dsv) |= SVt_IV; + break; + case SVt_NV: + case SVt_PV: + sv_upgrade(dsv, SVt_PVIV); + break; + case SVt_PVGV: + case SVt_PVLV: + goto end_of_first_switch; + } + (void)SvIOK_only(dsv); + SvIV_set(dsv, SvIVX(ssv)); + if (SvIsUV(ssv)) + SvIsUV_on(dsv); + /* SvTAINTED can only be true if the SV has taint magic, which in + turn means that the SV type is PVMG (or greater). This is the + case statement for SVt_IV, so this cannot be true (whatever gcov + may say). */ + assert(!SvTAINTED(ssv)); + return; + } + if (!SvROK(ssv)) + goto undef_sstr; + if (dtype < SVt_PV && dtype != SVt_IV) + sv_upgrade(dsv, SVt_IV); + break; case SVt_NV: - if (LIKELY( SvNOK(ssv) )) { - switch (dtype) { - case SVt_NULL: - case SVt_IV: - sv_upgrade(dsv, SVt_NV); - break; - case SVt_PV: - case SVt_PVIV: - sv_upgrade(dsv, SVt_PVNV); - break; - case SVt_PVGV: - case SVt_PVLV: - goto end_of_first_switch; - } - SvNV_set(dsv, SvNVX(ssv)); - (void)SvNOK_only(dsv); - /* SvTAINTED can only be true if the SV has taint magic, which in - turn means that the SV type is PVMG (or greater). This is the - case statement for SVt_NV, so this cannot be true (whatever gcov - may say). */ - assert(!SvTAINTED(ssv)); - return; - } - goto undef_sstr; + if (LIKELY( SvNOK(ssv) )) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: + sv_upgrade(dsv, SVt_NV); + break; + case SVt_PV: + case SVt_PVIV: + sv_upgrade(dsv, SVt_PVNV); + break; + case SVt_PVGV: + case SVt_PVLV: + goto end_of_first_switch; + } + SvNV_set(dsv, SvNVX(ssv)); + (void)SvNOK_only(dsv); + /* SvTAINTED can only be true if the SV has taint magic, which in + turn means that the SV type is PVMG (or greater). This is the + case statement for SVt_NV, so this cannot be true (whatever gcov + may say). */ + assert(!SvTAINTED(ssv)); + return; + } + goto undef_sstr; case SVt_PV: - if (dtype < SVt_PV) - sv_upgrade(dsv, SVt_PV); - break; + if (dtype < SVt_PV) + sv_upgrade(dsv, SVt_PV); + break; case SVt_PVIV: - if (dtype < SVt_PVIV) - sv_upgrade(dsv, SVt_PVIV); - break; + if (dtype < SVt_PVIV) + sv_upgrade(dsv, SVt_PVIV); + break; case SVt_PVNV: - if (dtype < SVt_PVNV) - sv_upgrade(dsv, SVt_PVNV); - break; + if (dtype < SVt_PVNV) + sv_upgrade(dsv, SVt_PVNV); + break; case SVt_INVLIST: invlist_clone(ssv, dsv); break; default: - { - const char * const type = sv_reftype(ssv,0); - if (PL_op) - /* diag_listed_as: Bizarre copy of %s */ - Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Bizarre copy of %s", type); - } - NOT_REACHED; /* NOTREACHED */ + { + const char * const type = sv_reftype(ssv,0); + if (PL_op) + /* diag_listed_as: Bizarre copy of %s */ + Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Bizarre copy of %s", type); + } + NOT_REACHED; /* NOTREACHED */ case SVt_REGEXP: upgregexp: - if (dtype < SVt_REGEXP) - sv_upgrade(dsv, SVt_REGEXP); - break; + if (dtype < SVt_REGEXP) + sv_upgrade(dsv, SVt_REGEXP); + break; case SVt_PVLV: case SVt_PVGV: case SVt_PVMG: - if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) { - mg_get(ssv); - if (SvTYPE(ssv) != stype) - stype = SvTYPE(ssv); - } - if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) { - glob_assign_glob(dsv, ssv, dtype); - return; - } - if (stype == SVt_PVLV) - { - if (isREGEXP(ssv)) goto upgregexp; - SvUPGRADE(dsv, SVt_PVNV); - } - else - SvUPGRADE(dsv, (svtype)stype); + if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) { + mg_get(ssv); + if (SvTYPE(ssv) != stype) + stype = SvTYPE(ssv); + } + if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) { + glob_assign_glob(dsv, ssv, dtype); + return; + } + if (stype == SVt_PVLV) + { + if (isREGEXP(ssv)) goto upgregexp; + SvUPGRADE(dsv, SVt_PVNV); + } + else + SvUPGRADE(dsv, (svtype)stype); } end_of_first_switch: @@ -4425,175 +4425,175 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) sflags = SvFLAGS(ssv); if (UNLIKELY( dtype == SVt_PVCV )) { - /* Assigning to a subroutine sets the prototype. */ - if (SvOK(ssv)) { - STRLEN len; - const char *const ptr = SvPV_const(ssv, len); + /* Assigning to a subroutine sets the prototype. */ + if (SvOK(ssv)) { + STRLEN len; + const char *const ptr = SvPV_const(ssv, len); SvGROW(dsv, len + 1); Copy(ptr, SvPVX(dsv), len + 1, char); SvCUR_set(dsv, len); - SvPOK_only(dsv); - SvFLAGS(dsv) |= sflags & SVf_UTF8; - CvAUTOLOAD_off(dsv); - } else { - SvOK_off(dsv); - } + SvPOK_only(dsv); + SvFLAGS(dsv) |= sflags & SVf_UTF8; + CvAUTOLOAD_off(dsv); + } else { + SvOK_off(dsv); + } } else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM)) { - const char * const type = sv_reftype(dsv,0); - if (PL_op) - /* diag_listed_as: Cannot copy to %s */ - Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Cannot copy to %s", type); + const char * const type = sv_reftype(dsv,0); + if (PL_op) + /* diag_listed_as: Cannot copy to %s */ + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { - if (isGV_with_GP(dsv) - && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) { - ssv = SvRV(ssv); - if (ssv == dsv) { - if (GvIMPORTED(dsv) != GVf_IMPORTED - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) - { - GvIMPORTED_on(dsv); - } - GvMULTI_on(dsv); - return; - } - glob_assign_glob(dsv, ssv, dtype); - return; - } - - if (dtype >= SVt_PV) { - if (isGV_with_GP(dsv)) { - gv_setref(dsv, ssv); - return; - } - if (SvPVX_const(dsv)) { - SvPV_free(dsv); - SvLEN_set(dsv, 0); + if (isGV_with_GP(dsv) + && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) { + ssv = SvRV(ssv); + if (ssv == dsv) { + if (GvIMPORTED(dsv) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) + { + GvIMPORTED_on(dsv); + } + GvMULTI_on(dsv); + return; + } + glob_assign_glob(dsv, ssv, dtype); + return; + } + + if (dtype >= SVt_PV) { + if (isGV_with_GP(dsv)) { + gv_setref(dsv, ssv); + return; + } + if (SvPVX_const(dsv)) { + SvPV_free(dsv); + SvLEN_set(dsv, 0); SvCUR_set(dsv, 0); - } - } - (void)SvOK_off(dsv); - SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv))); - SvFLAGS(dsv) |= sflags & SVf_ROK; - assert(!(sflags & SVp_NOK)); - assert(!(sflags & SVp_IOK)); - assert(!(sflags & SVf_NOK)); - assert(!(sflags & SVf_IOK)); + } + } + (void)SvOK_off(dsv); + SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv))); + SvFLAGS(dsv) |= sflags & SVf_ROK; + assert(!(sflags & SVp_NOK)); + assert(!(sflags & SVp_IOK)); + assert(!(sflags & SVf_NOK)); + assert(!(sflags & SVf_IOK)); } else if (isGV_with_GP(dsv)) { - if (!(sflags & SVf_OK)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Undefined value assigned to typeglob"); - } - else { - GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV); - if (dsv != (const SV *)gv) { - const char * const name = GvNAME((const GV *)dsv); - const STRLEN len = GvNAMELEN(dsv); - HV *old_stash = NULL; - bool reset_isa = FALSE; - if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') - || (len == 1 && name[0] == ':')) { - /* Set aside the old stash, so we can reset isa caches - on its subclasses. */ - if((old_stash = GvHV(dsv))) { - /* Make sure we do not lose it early. */ - SvREFCNT_inc_simple_void_NN( - sv_2mortal((SV *)old_stash) - ); - } - reset_isa = TRUE; - } - - if (GvGP(dsv)) { - SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv)); - gp_free(MUTABLE_GV(dsv)); - } - GvGP_set(dsv, gp_ref(GvGP(gv))); - - if (reset_isa) { - HV * const stash = GvHV(dsv); - if( - old_stash ? (HV *)HvENAME_get(old_stash) : stash - ) - mro_package_moved( - stash, old_stash, - (GV *)dsv, 0 - ); - } - } - } + if (!(sflags & SVf_OK)) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Undefined value assigned to typeglob"); + } + else { + GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV); + if (dsv != (const SV *)gv) { + const char * const name = GvNAME((const GV *)dsv); + const STRLEN len = GvNAMELEN(dsv); + HV *old_stash = NULL; + bool reset_isa = FALSE; + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { + /* Set aside the old stash, so we can reset isa caches + on its subclasses. */ + if((old_stash = GvHV(dsv))) { + /* Make sure we do not lose it early. */ + SvREFCNT_inc_simple_void_NN( + sv_2mortal((SV *)old_stash) + ); + } + reset_isa = TRUE; + } + + if (GvGP(dsv)) { + SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv)); + gp_free(MUTABLE_GV(dsv)); + } + GvGP_set(dsv, gp_ref(GvGP(gv))); + + if (reset_isa) { + HV * const stash = GvHV(dsv); + if( + old_stash ? (HV *)HvENAME_get(old_stash) : stash + ) + mro_package_moved( + stash, old_stash, + (GV *)dsv, 0 + ); + } + } + } } else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV) - && (stype == SVt_REGEXP || isREGEXP(ssv))) { - reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv); + && (stype == SVt_REGEXP || isREGEXP(ssv))) { + reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv); } else if (sflags & SVp_POK) { - const STRLEN cur = SvCUR(ssv); - const STRLEN len = SvLEN(ssv); - - /* - * We have three basic ways to copy the string: - * - * 1. Swipe - * 2. Copy-on-write - * 3. Actual copy - * - * Which we choose is based on various factors. The following - * things are listed in order of speed, fastest to slowest: - * - Swipe - * - Copying a short string - * - Copy-on-write bookkeeping - * - malloc - * - Copying a long string - * - * We swipe the string (steal the string buffer) if the SV on the - * rhs is about to be freed anyway (TEMP and refcnt==1). This is a - * big win on long strings. It should be a win on short strings if - * SvPVX_const(dsv) has to be allocated. If not, it should not - * slow things down, as SvPVX_const(ssv) would have been freed - * soon anyway. - * - * We also steal the buffer from a PADTMP (operator target) if it - * is ‘long enough’. For short strings, a swipe does not help - * here, as it causes more malloc calls the next time the target - * is used. Benchmarks show that even if SvPVX_const(dsv) has to - * be allocated it is still not worth swiping PADTMPs for short - * strings, as the savings here are small. - * - * If swiping is not an option, then we see whether it is - * worth using copy-on-write. If the lhs already has a buf- - * fer big enough and the string is short, we skip it and fall back - * to method 3, since memcpy is faster for short strings than the - * later bookkeeping overhead that copy-on-write entails. - - * If the rhs is not a copy-on-write string yet, then we also - * consider whether the buffer is too large relative to the string - * it holds. Some operations such as readline allocate a large - * buffer in the expectation of reusing it. But turning such into - * a COW buffer is counter-productive because it increases memory - * usage by making readline allocate a new large buffer the sec- - * ond time round. So, if the buffer is too large, again, we use - * method 3 (copy). - * - * Finally, if there is no buffer on the left, or the buffer is too - * small, then we use copy-on-write and make both SVs share the - * string buffer. - * - */ - - /* Whichever path we take through the next code, we want this true, - and doing it now facilitates the COW check. */ - (void)SvPOK_only(dsv); - - if ( + const STRLEN cur = SvCUR(ssv); + const STRLEN len = SvLEN(ssv); + + /* + * We have three basic ways to copy the string: + * + * 1. Swipe + * 2. Copy-on-write + * 3. Actual copy + * + * Which we choose is based on various factors. The following + * things are listed in order of speed, fastest to slowest: + * - Swipe + * - Copying a short string + * - Copy-on-write bookkeeping + * - malloc + * - Copying a long string + * + * We swipe the string (steal the string buffer) if the SV on the + * rhs is about to be freed anyway (TEMP and refcnt==1). This is a + * big win on long strings. It should be a win on short strings if + * SvPVX_const(dsv) has to be allocated. If not, it should not + * slow things down, as SvPVX_const(ssv) would have been freed + * soon anyway. + * + * We also steal the buffer from a PADTMP (operator target) if it + * is ‘long enough’. For short strings, a swipe does not help + * here, as it causes more malloc calls the next time the target + * is used. Benchmarks show that even if SvPVX_const(dsv) has to + * be allocated it is still not worth swiping PADTMPs for short + * strings, as the savings here are small. + * + * If swiping is not an option, then we see whether it is + * worth using copy-on-write. If the lhs already has a buf- + * fer big enough and the string is short, we skip it and fall back + * to method 3, since memcpy is faster for short strings than the + * later bookkeeping overhead that copy-on-write entails. + + * If the rhs is not a copy-on-write string yet, then we also + * consider whether the buffer is too large relative to the string + * it holds. Some operations such as readline allocate a large + * buffer in the expectation of reusing it. But turning such into + * a COW buffer is counter-productive because it increases memory + * usage by making readline allocate a new large buffer the sec- + * ond time round. So, if the buffer is too large, again, we use + * method 3 (copy). + * + * Finally, if there is no buffer on the left, or the buffer is too + * small, then we use copy-on-write and make both SVs share the + * string buffer. + * + */ + + /* Whichever path we take through the next code, we want this true, + and doing it now facilitates the COW check. */ + (void)SvPOK_only(dsv); + + if ( ( /* Either ... */ - /* slated for free anyway (and not COW)? */ + /* slated for free anyway (and not COW)? */ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP /* or a swipable TARG */ || ((sflags & @@ -4604,41 +4604,41 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) ) ) && !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ - (!(flags & SV_NOSTEAL)) && - /* and we're allowed to steal temps */ + (!(flags & SV_NOSTEAL)) && + /* and we're allowed to steal temps */ SvREFCNT(ssv) == 1 && /* and no other references to it? */ len) /* and really is a string */ - { /* Passes the swipe test. */ - if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */ - SvPV_free(dsv); - SvPV_set(dsv, SvPVX_mutable(ssv)); - SvLEN_set(dsv, SvLEN(ssv)); - SvCUR_set(dsv, SvCUR(ssv)); - - SvTEMP_off(dsv); - (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */ - SvPV_set(ssv, NULL); - SvLEN_set(ssv, 0); - SvCUR_set(ssv, 0); - SvTEMP_off(ssv); - } - else if (flags & SV_COW_SHARED_HASH_KEYS - && + { /* Passes the swipe test. */ + if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */ + SvPV_free(dsv); + SvPV_set(dsv, SvPVX_mutable(ssv)); + SvLEN_set(dsv, SvLEN(ssv)); + SvCUR_set(dsv, SvCUR(ssv)); + + SvTEMP_off(dsv); + (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */ + SvPV_set(ssv, NULL); + SvLEN_set(ssv, 0); + SvCUR_set(ssv, 0); + SvTEMP_off(ssv); + } + else if (flags & SV_COW_SHARED_HASH_KEYS + && #ifdef PERL_COPY_ON_WRITE - (sflags & SVf_IsCOW - ? (!len || + (sflags & SVf_IsCOW + ? (!len || ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - /* If this is a regular (non-hek) COW, only so - many COW "copies" are possible. */ - && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) - : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && !(SvFLAGS(dsv) & SVf_BREAK) + /* If this is a regular (non-hek) COW, only so + many COW "copies" are possible. */ + && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) + : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && !(SvFLAGS(dsv) & SVf_BREAK) && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - )) + )) #else - sflags & SVf_IsCOW - && !(SvFLAGS(dsv) & SVf_BREAK) + sflags & SVf_IsCOW + && !(SvFLAGS(dsv) & SVf_BREAK) #endif ) { /* Either it's a shared hash key, or it's suitable for @@ -4653,19 +4653,19 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) #ifdef PERL_ANY_COW if (!(sflags & SVf_IsCOW)) { SvIsCOW_on(ssv); - CowREFCNT(ssv) = 0; + CowREFCNT(ssv) = 0; } #endif - if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */ - SvPV_free(dsv); - } + if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */ + SvPV_free(dsv); + } #ifdef PERL_ANY_COW - if (len) { - if (sflags & SVf_IsCOW) { - sv_buf_to_rw(ssv); - } - CowREFCNT(ssv)++; + if (len) { + if (sflags & SVf_IsCOW) { + sv_buf_to_rw(ssv); + } + CowREFCNT(ssv)++; SvPV_set(dsv, SvPVX_mutable(ssv)); sv_buf_to_ro(ssv); } else @@ -4675,59 +4675,59 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); - assert (SvTYPE(dsv) >= SVt_PV); + assert (SvTYPE(dsv) >= SVt_PV); SvPV_set(dsv, - HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))))); - } - SvLEN_set(dsv, len); - SvCUR_set(dsv, cur); - SvIsCOW_on(dsv); - } else { - /* Failed the swipe test, and we cannot do copy-on-write either. - Have to copy the string. */ - SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */ - Move(SvPVX_const(ssv),SvPVX(dsv),cur,char); - SvCUR_set(dsv, cur); - *SvEND(dsv) = '\0'; - } - if (sflags & SVp_NOK) { - SvNV_set(dsv, SvNVX(ssv)); - } - if (sflags & SVp_IOK) { - SvIV_set(dsv, SvIVX(ssv)); - if (sflags & SVf_IVisUV) - SvIsUV_on(dsv); - } - SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); - { - const MAGIC * const smg = SvVSTRING_mg(ssv); - if (smg) { - sv_magic(dsv, NULL, PERL_MAGIC_vstring, - smg->mg_ptr, smg->mg_len); - SvRMAGICAL_on(dsv); - } - } + HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))))); + } + SvLEN_set(dsv, len); + SvCUR_set(dsv, cur); + SvIsCOW_on(dsv); + } else { + /* Failed the swipe test, and we cannot do copy-on-write either. + Have to copy the string. */ + SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */ + Move(SvPVX_const(ssv),SvPVX(dsv),cur,char); + SvCUR_set(dsv, cur); + *SvEND(dsv) = '\0'; + } + if (sflags & SVp_NOK) { + SvNV_set(dsv, SvNVX(ssv)); + } + if (sflags & SVp_IOK) { + SvIV_set(dsv, SvIVX(ssv)); + if (sflags & SVf_IVisUV) + SvIsUV_on(dsv); + } + SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); + { + const MAGIC * const smg = SvVSTRING_mg(ssv); + if (smg) { + sv_magic(dsv, NULL, PERL_MAGIC_vstring, + smg->mg_ptr, smg->mg_len); + SvRMAGICAL_on(dsv); + } + } } else if (sflags & (SVp_IOK|SVp_NOK)) { - (void)SvOK_off(dsv); - SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); - if (sflags & SVp_IOK) { - /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - SvIV_set(dsv, SvIVX(ssv)); - } - if (sflags & SVp_NOK) { - SvNV_set(dsv, SvNVX(ssv)); - } + (void)SvOK_off(dsv); + SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); + if (sflags & SVp_IOK) { + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + SvIV_set(dsv, SvIVX(ssv)); + } + if (sflags & SVp_NOK) { + SvNV_set(dsv, SvNVX(ssv)); + } } else { - if (isGV_with_GP(ssv)) { - gv_efullname3(dsv, MUTABLE_GV(ssv), "*"); - } - else - (void)SvOK_off(dsv); + if (isGV_with_GP(ssv)) { + gv_efullname3(dsv, MUTABLE_GV(ssv), "*"); + } + else + (void)SvOK_off(dsv); } if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); } @@ -4815,21 +4815,21 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) PERL_ARGS_ASSERT_SV_SETSV_COW; #ifdef DEBUGGING if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", - (void*)ssv, (void*)dsv); - sv_dump(ssv); - if (dsv) - sv_dump(dsv); + PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", + (void*)ssv, (void*)dsv); + sv_dump(ssv); + if (dsv) + sv_dump(dsv); } #endif if (dsv) { - if (SvTHINKFIRST(dsv)) - sv_force_normal_flags(dsv, SV_COW_DROP_PV); - else if (SvPVX_const(dsv)) - Safefree(SvPVX_mutable(dsv)); + if (SvTHINKFIRST(dsv)) + sv_force_normal_flags(dsv, SV_COW_DROP_PV); + else if (SvPVX_const(dsv)) + Safefree(SvPVX_mutable(dsv)); } else - new_SV(dsv); + new_SV(dsv); SvUPGRADE(dsv, SVt_COW); assert (SvPOK(ssv)); @@ -4837,22 +4837,22 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) if (SvIsCOW(ssv)) { - if (SvLEN(ssv) == 0) { - /* source is a COW shared hash key. */ - DEBUG_C(PerlIO_printf(Perl_debug_log, - "Fast copy on write: Sharing hash\n")); - new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))); - goto common_exit; - } - assert(SvCUR(ssv)+1 < SvLEN(ssv)); - assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX); + if (SvLEN(ssv) == 0) { + /* source is a COW shared hash key. */ + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Sharing hash\n")); + new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))); + goto common_exit; + } + assert(SvCUR(ssv)+1 < SvLEN(ssv)); + assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX); } else { - assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS); - SvUPGRADE(ssv, SVt_COW); - SvIsCOW_on(ssv); - DEBUG_C(PerlIO_printf(Perl_debug_log, - "Fast copy on write: Converting ssv to COW\n")); - CowREFCNT(ssv) = 0; + assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS); + SvUPGRADE(ssv, SVt_COW); + SvIsCOW_on(ssv); + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Converting ssv to COW\n")); + CowREFCNT(ssv) = 0; } # ifdef PERL_DEBUG_READONLY_COW if (already) sv_buf_to_rw(ssv); @@ -4865,12 +4865,12 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) SvPV_set(dsv, new_pv); SvFLAGS(dsv) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); if (SvUTF8(ssv)) - SvUTF8_on(dsv); + SvUTF8_on(dsv); SvLEN_set(dsv, len); SvCUR_set(dsv, cur); #ifdef DEBUGGING if (DEBUG_C_TEST) - sv_dump(dsv); + sv_dump(dsv); #endif return dsv; } @@ -4933,17 +4933,17 @@ Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) SV_CHECK_THINKFIRST_COW_DROP(sv); if (isGV_with_GP(sv)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (!ptr) { - (void)SvOK_off(sv); - return; + (void)SvOK_off(sv); + return; } else { /* len is STRLEN which is unsigned, need to copy to signed */ - const IV iv = len; - if (iv < 0) - Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" - IVdf, iv); + const IV iv = len; + if (iv < 0) + Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" + IVdf, iv); } SvUPGRADE(sv, SVt_PV); @@ -4988,8 +4988,8 @@ Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { - (void)SvOK_off(sv); - return; + (void)SvOK_off(sv); + return; } len = strlen(ptr); SvUPGRADE(sv, SVt_PV); @@ -5017,41 +5017,41 @@ Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) PERL_ARGS_ASSERT_SV_SETHEK; if (!hek) { - return; + return; } if (HEK_LEN(hek) == HEf_SVKEY) { - sv_setsv(sv, *(SV**)HEK_KEY(hek)); + sv_setsv(sv, *(SV**)HEK_KEY(hek)); return; } else { - const int flags = HEK_FLAGS(hek); - if (flags & HVhek_WASUTF8) { - STRLEN utf8_len = HEK_LEN(hek); - char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); - sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); - SvUTF8_on(sv); + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + STRLEN utf8_len = HEK_LEN(hek); + char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); + sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); + SvUTF8_on(sv); return; } else if (flags & HVhek_UNSHARED) { - sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - else SvUTF8_off(sv); + sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + else SvUTF8_off(sv); return; - } + } { - SV_CHECK_THINKFIRST_COW_DROP(sv); - SvUPGRADE(sv, SVt_PV); - SvPV_free(sv); - SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); - SvCUR_set(sv, HEK_LEN(hek)); - SvLEN_set(sv, 0); - SvIsCOW_on(sv); - SvPOK_on(sv); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - else SvUTF8_off(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); + SvUPGRADE(sv, SVt_PV); + SvPV_free(sv); + SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); + SvLEN_set(sv, 0); + SvIsCOW_on(sv); + SvPOK_on(sv); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + else SvUTF8_off(sv); return; - } + } } } @@ -5094,39 +5094,39 @@ Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 SV_CHECK_THINKFIRST_COW_DROP(sv); SvUPGRADE(sv, SVt_PV); if (!ptr) { - (void)SvOK_off(sv); - if (flags & SV_SMAGIC) - SvSETMAGIC(sv); - return; + (void)SvOK_off(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); + return; } if (SvPVX_const(sv)) - SvPV_free(sv); + SvPV_free(sv); #ifdef DEBUGGING if (flags & SV_HAS_TRAILING_NUL) - assert(ptr[len] == '\0'); + assert(ptr[len] == '\0'); #endif allocate = (flags & SV_HAS_TRAILING_NUL) - ? len + 1 : + ? len + 1 : #ifdef Perl_safesysmalloc_size - len + 1; + len + 1; #else - PERL_STRLEN_ROUNDUP(len + 1); + PERL_STRLEN_ROUNDUP(len + 1); #endif if (flags & SV_HAS_TRAILING_NUL) { - /* It's long enough - do nothing. - Specifically Perl_newCONSTSUB is relying on this. */ + /* It's long enough - do nothing. + Specifically Perl_newCONSTSUB is relying on this. */ } else { #ifdef DEBUGGING - /* Force a move to shake out bugs in callers. */ - char *new_ptr = (char*)safemalloc(allocate); - Copy(ptr, new_ptr, len, char); - PoisonFree(ptr,len,char); - Safefree(ptr); - ptr = new_ptr; + /* Force a move to shake out bugs in callers. */ + char *new_ptr = (char*)safemalloc(allocate); + Copy(ptr, new_ptr, len, char); + PoisonFree(ptr,len,char); + Safefree(ptr); + ptr = new_ptr; #else - ptr = (char*) saferealloc (ptr, allocate); + ptr = (char*) saferealloc (ptr, allocate); #endif } #ifdef Perl_safesysmalloc_size @@ -5137,12 +5137,12 @@ Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 SvCUR_set(sv, len); SvPV_set(sv, ptr); if (!(flags & SV_HAS_TRAILING_NUL)) { - ptr[len] = '\0'; + ptr[len] = '\0'; } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); if (flags & SV_SMAGIC) - SvSETMAGIC(sv); + SvSETMAGIC(sv); } @@ -5152,9 +5152,9 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) assert(SvIsCOW(sv)); { #ifdef PERL_ANY_COW - const char * const pvx = SvPVX_const(sv); - const STRLEN len = SvLEN(sv); - const STRLEN cur = SvCUR(sv); + const char * const pvx = SvPVX_const(sv); + const STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); #ifdef DEBUGGING if (DEBUG_C_TEST) { @@ -5166,25 +5166,25 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) #endif SvIsCOW_off(sv); # ifdef PERL_COPY_ON_WRITE - if (len) { - /* Must do this first, since the CowREFCNT uses SvPVX and - we need to write to CowREFCNT, or de-RO the whole buffer if we are - the only owner left of the buffer. */ - sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */ - { - U8 cowrefcnt = CowREFCNT(sv); - if(cowrefcnt != 0) { - cowrefcnt--; - CowREFCNT(sv) = cowrefcnt; - sv_buf_to_ro(sv); - goto copy_over; - } - } - /* Else we are the only owner of the buffer. */ - } - else + if (len) { + /* Must do this first, since the CowREFCNT uses SvPVX and + we need to write to CowREFCNT, or de-RO the whole buffer if we are + the only owner left of the buffer. */ + sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */ + { + U8 cowrefcnt = CowREFCNT(sv); + if(cowrefcnt != 0) { + cowrefcnt--; + CowREFCNT(sv) = cowrefcnt; + sv_buf_to_ro(sv); + goto copy_over; + } + } + /* Else we are the only owner of the buffer. */ + } + else # endif - { + { /* This SV doesn't own the buffer, so need to Newx() a new one: */ copy_over: SvPV_set(sv, NULL); @@ -5199,29 +5199,29 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - if (! len) { - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); - } + if (! len) { + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + } #ifdef DEBUGGING if (DEBUG_C_TEST) sv_dump(sv); #endif - } + } #else - const char * const pvx = SvPVX_const(sv); - const STRLEN len = SvCUR(sv); - SvIsCOW_off(sv); - SvPV_set(sv, NULL); - SvLEN_set(sv, 0); - if (flags & SV_COW_DROP_PV) { - /* OK, so we don't need to copy our buffer. */ - SvPOK_off(sv); - } else { - SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); - *SvEND(sv) = '\0'; - } - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + const char * const pvx = SvPVX_const(sv); + const STRLEN len = SvCUR(sv); + SvIsCOW_off(sv); + SvPV_set(sv, NULL); + SvLEN_set(sv, 0); + if (flags & SV_COW_DROP_PV) { + /* OK, so we don't need to copy our buffer. */ + SvPOK_off(sv); + } else { + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); #endif } } @@ -5258,32 +5258,32 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; if (SvREADONLY(sv)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV)) - S_sv_uncow(aTHX_ sv, flags); + S_sv_uncow(aTHX_ sv, flags); if (SvROK(sv)) - sv_unref_flags(sv, flags); + sv_unref_flags(sv, flags); else if (SvFAKE(sv) && isGV_with_GP(sv)) - sv_unglob(sv, flags); + sv_unglob(sv, flags); else if (SvFAKE(sv) && isREGEXP(sv)) { - /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous - to sv_unglob. We only need it here, so inline it. */ - const bool islv = SvTYPE(sv) == SVt_PVLV; - const svtype new_type = - islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; - SV *const temp = newSV_type(new_type); - regexp *old_rx_body; - - if (new_type == SVt_PVMG) { - SvMAGIC_set(temp, SvMAGIC(sv)); - SvMAGIC_set(sv, NULL); - SvSTASH_set(temp, SvSTASH(sv)); - SvSTASH_set(sv, NULL); - } - if (!islv) + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous + to sv_unglob. We only need it here, so inline it. */ + const bool islv = SvTYPE(sv) == SVt_PVLV; + const svtype new_type = + islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + SV *const temp = newSV_type(new_type); + regexp *old_rx_body; + + if (new_type == SVt_PVMG) { + SvMAGIC_set(temp, SvMAGIC(sv)); + SvMAGIC_set(sv, NULL); + SvSTASH_set(temp, SvSTASH(sv)); + SvSTASH_set(sv, NULL); + } + if (!islv) SvCUR_set(temp, SvCUR(sv)); - /* Remember that SvPVX is in the head, not the body. */ - assert(ReANY((REGEXP *)sv)->mother_re); + /* Remember that SvPVX is in the head, not the body. */ + assert(ReANY((REGEXP *)sv)->mother_re); if (islv) { /* LV-as-regex has sv->sv_any pointing to an XPVLV body, @@ -5295,34 +5295,34 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) else old_rx_body = ReANY((REGEXP *)sv); - /* Their buffer is already owned by someone else. */ - if (flags & SV_COW_DROP_PV) { - /* SvLEN is already 0. For SVt_REGEXP, we have a brand new - zeroed body. For SVt_PVLV, we zeroed it above (len field + /* Their buffer is already owned by someone else. */ + if (flags & SV_COW_DROP_PV) { + /* SvLEN is already 0. For SVt_REGEXP, we have a brand new + zeroed body. For SVt_PVLV, we zeroed it above (len field a union with xpvlenu_rx) */ - assert(!SvLEN(islv ? sv : temp)); - sv->sv_u.svu_pv = 0; - } - else { - sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); - SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); - SvPOK_on(sv); - } - - /* Now swap the rest of the bodies. */ - - SvFAKE_off(sv); - if (!islv) { - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= new_type; - SvANY(sv) = SvANY(temp); - } - - SvFLAGS(temp) &= ~(SVTYPEMASK); - SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; - SvANY(temp) = old_rx_body; - - SvREFCNT_dec_NN(temp); + assert(!SvLEN(islv ? sv : temp)); + sv->sv_u.svu_pv = 0; + } + else { + sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); + SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); + SvPOK_on(sv); + } + + /* Now swap the rest of the bodies. */ + + SvFAKE_off(sv); + if (!islv) { + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + } + + SvFLAGS(temp) &= ~(SVTYPEMASK); + SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; + SvANY(temp) = old_rx_body; + + SvREFCNT_dec_NN(temp); } else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); } @@ -5361,32 +5361,32 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) PERL_ARGS_ASSERT_SV_CHOP; if (!ptr || !SvPOKp(sv)) - return; + return; delta = ptr - SvPVX_const(sv); if (!delta) { - /* Nothing to do. */ - return; + /* Nothing to do. */ + return; } max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); if (delta > max_delta) - Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", - ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); + Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", + ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */ SV_CHECK_THINKFIRST(sv); SvPOK_only_UTF8(sv); if (!SvOOK(sv)) { - if (!SvLEN(sv)) { /* make copy of shared string */ - const char *pvx = SvPVX_const(sv); - const STRLEN len = SvCUR(sv); - SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); - *SvEND(sv) = '\0'; - } - SvOOK_on(sv); - old_delta = 0; + if (!SvLEN(sv)) { /* make copy of shared string */ + const char *pvx = SvPVX_const(sv); + const STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } + SvOOK_on(sv); + old_delta = 0; } else { - SvOOK_offset(sv, old_delta); + SvOOK_offset(sv, old_delta); } SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); @@ -5399,7 +5399,7 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) bytes, except for the part holding the new offset of course. */ evacn = delta; if (old_delta) - evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); + evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); assert(evacn); assert(evacn <= delta + old_delta); evacp = p - evacn; @@ -5414,19 +5414,19 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a * portion of the chopped part of the string */ if (delta < 0x100) { - *--p = (U8) delta; + *--p = (U8) delta; } else { - *--p = 0; - p -= sizeof(STRLEN); - Copy((U8*)&delta, p, sizeof(STRLEN), U8); + *--p = 0; + p -= sizeof(STRLEN); + Copy((U8*)&delta, p, sizeof(STRLEN), U8); } #ifdef DEBUGGING /* Fill the preceding buffer with sentinals to verify that no-one is using it. */ while (p > evacp) { - --p; - *p = (U8)PTR2UV(p); + --p; + *p = (U8)PTR2UV(p); } #endif } @@ -5479,39 +5479,39 @@ Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, c if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) { if (flags & SV_CATUTF8 && !SvUTF8(dsv)) { - sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); - dlen = SvCUR(dsv); + sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); + dlen = SvCUR(dsv); } else SvGROW(dsv, dlen + slen + 3); if (sstr == dstr) - sstr = SvPVX_const(dsv); + sstr = SvPVX_const(dsv); Move(sstr, SvPVX(dsv) + dlen, slen, char); SvCUR_set(dsv, SvCUR(dsv) + slen); } else { - /* We inline bytes_to_utf8, to avoid an extra malloc. */ - const char * const send = sstr + slen; - U8 *d; + /* We inline bytes_to_utf8, to avoid an extra malloc. */ + const char * const send = sstr + slen; + U8 *d; - /* Something this code does not account for, which I think is - impossible; it would require the same pv to be treated as - bytes *and* utf8, which would indicate a bug elsewhere. */ - assert(sstr != dstr); + /* Something this code does not account for, which I think is + impossible; it would require the same pv to be treated as + bytes *and* utf8, which would indicate a bug elsewhere. */ + assert(sstr != dstr); - SvGROW(dsv, dlen + slen * 2 + 3); - d = (U8 *)SvPVX(dsv) + dlen; + SvGROW(dsv, dlen + slen * 2 + 3); + d = (U8 *)SvPVX(dsv) + dlen; - while (sstr < send) { + while (sstr < send) { append_utf8_from_native_byte(*sstr, &d); - sstr++; - } - SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); + sstr++; + } + SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); } *SvEND(dsv) = '\0'; (void)SvPOK_only_UTF8(dsv); /* validate pointer */ SvTAINT(dsv); if (flags & SV_SMAGIC) - SvSETMAGIC(dsv); + SvSETMAGIC(dsv); } /* @@ -5548,12 +5548,12 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags) PERL_ARGS_ASSERT_SV_CATSV_FLAGS; if (sstr) { - STRLEN slen; - const char *spv = SvPV_flags_const(sstr, slen, flags); + STRLEN slen; + const char *spv = SvPV_flags_const(sstr, slen, flags); if (flags & SV_GMAGIC) SvGETMAGIC(dsv); sv_catpvn_flags(dsv, spv, slen, - DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES); + DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES); if (flags & SV_SMAGIC) SvSETMAGIC(dsv); } @@ -5598,12 +5598,12 @@ Perl_sv_catpv(pTHX_ SV *const dsv, const char *sstr) PERL_ARGS_ASSERT_SV_CATPV; if (!sstr) - return; + return; junk = SvPV_force(dsv, tlen); len = strlen(sstr); SvGROW(dsv, tlen + len + 1); if (sstr == junk) - sstr = SvPVX_const(dsv); + sstr = SvPVX_const(dsv); Move(sstr,SvPVX(dsv)+tlen,len+1,char); SvCUR_set(dsv, SvCUR(dsv) + len); (void)SvPOK_only_UTF8(dsv); /* validate pointer */ @@ -5650,7 +5650,7 @@ Perl_newSV(pTHX_ const STRLEN len) new_SV(sv); if (len) { - sv_grow(sv, len + 1); + sv_grow(sv, len + 1); } return sv; } @@ -5696,20 +5696,20 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, */ if (!obj || obj == sv || - how == PERL_MAGIC_arylen || + how == PERL_MAGIC_arylen || how == PERL_MAGIC_regdata || how == PERL_MAGIC_regdatum || how == PERL_MAGIC_symtab || - (SvTYPE(obj) == SVt_PVGV && - (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv - || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv - || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) + (SvTYPE(obj) == SVt_PVGV && + (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv + || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv + || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) { - mg->mg_obj = obj; + mg->mg_obj = obj; } else { - mg->mg_obj = SvREFCNT_inc_simple(obj); - mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = SvREFCNT_inc_simple(obj); + mg->mg_flags |= MGf_REFCOUNTED; } /* Normal self-ties simply pass a null object, and instead of @@ -5729,16 +5729,16 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, mg->mg_type = how; mg->mg_len = namlen; if (name) { - if (namlen > 0) - mg->mg_ptr = savepvn(name, namlen); - else if (namlen == HEf_SVKEY) { - /* Yes, this is casting away const. This is only for the case of - HEf_SVKEY. I think we need to document this aberation of the - constness of the API, rather than making name non-const, as - that change propagating outwards a long way. */ - mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); - } else - mg->mg_ptr = (char *) name; + if (namlen > 0) + mg->mg_ptr = savepvn(name, namlen); + else if (namlen == HEf_SVKEY) { + /* Yes, this is casting away const. This is only for the case of + HEf_SVKEY. I think we need to document this aberation of the + constness of the API, rather than making name non-const, as + that change propagating outwards a long way. */ + mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); + } else + mg->mg_ptr = (char *) name; } mg->mg_virtual = (MGVTBL *) vtable; @@ -5751,13 +5751,13 @@ Perl_sv_magicext_mglob(pTHX_ SV *sv) { PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { - /* This sv is only a delegate. //g magic must be attached to - its target. */ - vivify_defelem(sv); - sv = LvTARG(sv); + /* This sv is only a delegate. //g magic must be attached to + its target. */ + vivify_defelem(sv); + sv = LvTARG(sv); } return sv_magicext(sv, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, 0, 0); + &PL_vtbl_mglob, 0, 0); } /* @@ -5788,10 +5788,10 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, PERL_ARGS_ASSERT_SV_MAGIC; if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data) - || ((flags = PL_magic_data[how]), - (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) - > magic_vtable_max)) - Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); + || ((flags = PL_magic_data[how]), + (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) + > magic_vtable_max)) + Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); /* PERL_MAGIC_ext is reserved for use by extensions not perl internals. Useful for attaching extension internal data to perl vars. @@ -5799,25 +5799,25 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, etc holding private data from one are passed to another. */ vtable = (vtable_index == magic_vtable_max) - ? NULL : PL_magic_vtables + vtable_index; + ? NULL : PL_magic_vtables + vtable_index; if (SvREADONLY(sv)) { - if ( - !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) - ) - { - Perl_croak_no_modify(); - } + if ( + !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) + ) + { + Perl_croak_no_modify(); + } } if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { - if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - /* sv_magic() refuses to add a magic of the same 'how' as an - existing one - */ - if (how == PERL_MAGIC_taint) - mg->mg_len |= 1; - return; - } + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + /* sv_magic() refuses to add a magic of the same 'how' as an + existing one + */ + if (how == PERL_MAGIC_taint) + mg->mg_len |= 1; + return; + } } /* Force pos to be stored as characters, not bytes. */ @@ -5825,9 +5825,9 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, && (mg = mg_find(sv, PERL_MAGIC_regex_global)) && mg->mg_len != -1 && mg->mg_flags & MGf_BYTES) { - mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, - SV_CONST_RETURN); - mg->mg_flags &= ~MGf_BYTES; + mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, + SV_CONST_RETURN); + mg->mg_flags &= ~MGf_BYTES; } /* Rest of work is done else where */ @@ -5835,12 +5835,12 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, switch (how) { case PERL_MAGIC_taint: - mg->mg_len = 1; - break; + mg->mg_len = 1; + break; case PERL_MAGIC_ext: case PERL_MAGIC_dbfile: - SvRMAGICAL_on(sv); - break; + SvRMAGICAL_on(sv); + break; } } @@ -5853,35 +5853,35 @@ S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U3 assert(flags <= 1); if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) - return 0; + return 0; mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); for (mg = *mgp; mg; mg = *mgp) { - const MGVTBL* const virt = mg->mg_virtual; - if (mg->mg_type == type && (!flags || virt == vtbl)) { - *mgp = mg->mg_moremagic; - if (virt && virt->svt_free) - virt->svt_free(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); - else if (mg->mg_type == PERL_MAGIC_utf8) - Safefree(mg->mg_ptr); + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && (!flags || virt == vtbl)) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); - } - else - mgp = &mg->mg_moremagic; + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { - if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ - mg_magical(sv); /* else fix the flags now */ + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ } else - SvMAGICAL_off(sv); + SvMAGICAL_off(sv); return 0; } @@ -5937,12 +5937,12 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_RVWEAKEN; if (!SvOK(sv)) /* let undefs pass */ - return sv; + return sv; if (!SvROK(sv)) - Perl_croak(aTHX_ "Can't weaken a nonreference"); + Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); - return sv; + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); + return sv; } else if (SvREADONLY(sv)) croak_no_modify(); tsv = SvRV(sv); @@ -6066,36 +6066,36 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) /* find slot to store array or singleton backref */ if (SvTYPE(tsv) == SVt_PVHV) { - svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); + svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } else { if (SvMAGICAL(tsv)) mg = mg_find(tsv, PERL_MAGIC_backref); - if (!mg) + if (!mg) mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0); - svp = &(mg->mg_obj); + svp = &(mg->mg_obj); } /* create or retrieve the array */ if ( (!*svp && SvTYPE(sv) == SVt_PVAV) - || (*svp && SvTYPE(*svp) != SVt_PVAV) + || (*svp && SvTYPE(*svp) != SVt_PVAV) ) { - /* create array */ - if (mg) - mg->mg_flags |= MGf_REFCOUNTED; - av = newAV(); - AvREAL_off(av); - SvREFCNT_inc_simple_void_NN(av); - /* av now has a refcnt of 2; see discussion above */ - av_extend(av, *svp ? 2 : 1); - if (*svp) { - /* move single existing backref to the array */ - AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ - } - *svp = (SV*)av; + /* create array */ + if (mg) + mg->mg_flags |= MGf_REFCOUNTED; + av = newAV(); + AvREAL_off(av); + SvREFCNT_inc_simple_void_NN(av); + /* av now has a refcnt of 2; see discussion above */ + av_extend(av, *svp ? 2 : 1); + if (*svp) { + /* move single existing backref to the array */ + AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ + } + *svp = (SV*)av; } else { - av = MUTABLE_AV(*svp); + av = MUTABLE_AV(*svp); if (!av) { /* optimisation: store single backref directly in HvAUX or mg_obj */ *svp = sv; @@ -6122,111 +6122,111 @@ Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) PERL_ARGS_ASSERT_SV_DEL_BACKREF; if (SvTYPE(tsv) == SVt_PVHV) { - if (SvOOK(tsv)) - svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); + if (SvOOK(tsv)) + svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) { - /* It's possible for the the last (strong) reference to tsv to have - become freed *before* the last thing holding a weak reference. - If both survive longer than the backreferences array, then when - the referent's reference count drops to 0 and it is freed, it's - not able to chase the backreferences, so they aren't NULLed. - - For example, a CV holds a weak reference to its stash. If both the - CV and the stash survive longer than the backreferences array, - and the CV gets picked for the SvBREAK() treatment first, - *and* it turns out that the stash is only being kept alive because - of an our variable in the pad of the CV, then midway during CV - destruction the stash gets freed, but CvSTASH() isn't set to NULL. - It ends up pointing to the freed HV. Hence it's chased in here, and - if this block wasn't here, it would hit the !svp panic just below. - - I don't believe that "better" destruction ordering is going to help - here - during global destruction there's always going to be the - chance that something goes out of order. We've tried to make it - foolproof before, and it only resulted in evolutionary pressure on - fools. Which made us look foolish for our hubris. :-( - */ - return; + /* It's possible for the the last (strong) reference to tsv to have + become freed *before* the last thing holding a weak reference. + If both survive longer than the backreferences array, then when + the referent's reference count drops to 0 and it is freed, it's + not able to chase the backreferences, so they aren't NULLed. + + For example, a CV holds a weak reference to its stash. If both the + CV and the stash survive longer than the backreferences array, + and the CV gets picked for the SvBREAK() treatment first, + *and* it turns out that the stash is only being kept alive because + of an our variable in the pad of the CV, then midway during CV + destruction the stash gets freed, but CvSTASH() isn't set to NULL. + It ends up pointing to the freed HV. Hence it's chased in here, and + if this block wasn't here, it would hit the !svp panic just below. + + I don't believe that "better" destruction ordering is going to help + here - during global destruction there's always going to be the + chance that something goes out of order. We've tried to make it + foolproof before, and it only resulted in evolutionary pressure on + fools. Which made us look foolish for our hubris. :-( + */ + return; } else { - MAGIC *const mg - = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; - svp = mg ? &(mg->mg_obj) : NULL; + MAGIC *const mg + = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; + svp = mg ? &(mg->mg_obj) : NULL; } if (!svp) - Perl_croak(aTHX_ "panic: del_backref, svp=0"); + Perl_croak(aTHX_ "panic: del_backref, svp=0"); if (!*svp) { - /* It's possible that sv is being freed recursively part way through the - freeing of tsv. If this happens, the backreferences array of tsv has - already been freed, and so svp will be NULL. If this is the case, - we should not panic. Instead, nothing needs doing, so return. */ - if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) - return; - Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, - (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); + /* It's possible that sv is being freed recursively part way through the + freeing of tsv. If this happens, the backreferences array of tsv has + already been freed, and so svp will be NULL. If this is the case, + we should not panic. Instead, nothing needs doing, so return. */ + if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) + return; + Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, + (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); } if (SvTYPE(*svp) == SVt_PVAV) { #ifdef DEBUGGING - int count = 1; + int count = 1; #endif - AV * const av = (AV*)*svp; - SSize_t fill; - assert(!SvIS_FREED(av)); - fill = AvFILLp(av); - assert(fill > -1); - svp = AvARRAY(av); - /* for an SV with N weak references to it, if all those - * weak refs are deleted, then sv_del_backref will be called - * N times and O(N^2) compares will be done within the backref - * array. To ameliorate this potential slowness, we: - * 1) make sure this code is as tight as possible; - * 2) when looking for SV, look for it at both the head and tail of the - * array first before searching the rest, since some create/destroy - * patterns will cause the backrefs to be freed in order. - */ - if (*svp == sv) { - AvARRAY(av)++; - AvMAX(av)--; - } - else { - SV **p = &svp[fill]; - SV *const topsv = *p; - if (topsv != sv) { + AV * const av = (AV*)*svp; + SSize_t fill; + assert(!SvIS_FREED(av)); + fill = AvFILLp(av); + assert(fill > -1); + svp = AvARRAY(av); + /* for an SV with N weak references to it, if all those + * weak refs are deleted, then sv_del_backref will be called + * N times and O(N^2) compares will be done within the backref + * array. To ameliorate this potential slowness, we: + * 1) make sure this code is as tight as possible; + * 2) when looking for SV, look for it at both the head and tail of the + * array first before searching the rest, since some create/destroy + * patterns will cause the backrefs to be freed in order. + */ + if (*svp == sv) { + AvARRAY(av)++; + AvMAX(av)--; + } + else { + SV **p = &svp[fill]; + SV *const topsv = *p; + if (topsv != sv) { #ifdef DEBUGGING - count = 0; + count = 0; #endif - while (--p > svp) { - if (*p == sv) { - /* We weren't the last entry. - An unordered list has this property that you - can take the last element off the end to fill - the hole, and it's still an unordered list :-) - */ - *p = topsv; + while (--p > svp) { + if (*p == sv) { + /* We weren't the last entry. + An unordered list has this property that you + can take the last element off the end to fill + the hole, and it's still an unordered list :-) + */ + *p = topsv; #ifdef DEBUGGING - count++; + count++; #else - break; /* should only be one */ + break; /* should only be one */ #endif - } - } - } - } - assert(count ==1); - AvFILLp(av) = fill-1; + } + } + } + } + assert(count ==1); + AvFILLp(av) = fill-1; } else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) { - /* freed AV; skip */ + /* freed AV; skip */ } else { - /* optimisation: only a single backref, stored directly */ - if (*svp != sv) - Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", + /* optimisation: only a single backref, stored directly */ + if (*svp != sv) + Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", (void*)*svp, (void*)sv); - *svp = NULL; + *svp = NULL; } } @@ -6241,82 +6241,82 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) PERL_ARGS_ASSERT_SV_KILL_BACKREFS; if (!av) - return; + return; /* after multiple passes through Perl_sv_clean_all() for a thingy * that has badly leaked, the backref array may have gotten freed, * since we only protect it against 1 round of cleanup */ if (SvIS_FREED(av)) { - if (PL_in_clean_all) /* All is fair */ - return; - Perl_croak(aTHX_ - "panic: magic_killbackrefs (freed backref AV/SV)"); + if (PL_in_clean_all) /* All is fair */ + return; + Perl_croak(aTHX_ + "panic: magic_killbackrefs (freed backref AV/SV)"); } is_array = (SvTYPE(av) == SVt_PVAV); if (is_array) { - assert(!SvIS_FREED(av)); - svp = AvARRAY(av); - if (svp) - last = svp + AvFILLp(av); + assert(!SvIS_FREED(av)); + svp = AvARRAY(av); + if (svp) + last = svp + AvFILLp(av); } else { - /* optimisation: only a single backref, stored directly */ - svp = (SV**)&av; - last = svp; + /* optimisation: only a single backref, stored directly */ + svp = (SV**)&av; + last = svp; } if (svp) { - while (svp <= last) { - if (*svp) { - SV *const referrer = *svp; - if (SvWEAKREF(referrer)) { - /* XXX Should we check that it hasn't changed? */ - assert(SvROK(referrer)); - SvRV_set(referrer, 0); - SvOK_off(referrer); - SvWEAKREF_off(referrer); - 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 || - SvTYPE(referrer) == SVt_PVFM) { - if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ - /* You lookin' at me? */ - assert(CvSTASH(referrer)); - assert(CvSTASH(referrer) == (const HV *)sv); - SvANY(MUTABLE_CV(referrer))->xcv_stash = 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 ")", - (UV)SvFLAGS(referrer)); - } - - if (is_array) - *svp = NULL; - } - svp++; - } + while (svp <= last) { + if (*svp) { + SV *const referrer = *svp; + if (SvWEAKREF(referrer)) { + /* XXX Should we check that it hasn't changed? */ + assert(SvROK(referrer)); + SvRV_set(referrer, 0); + SvOK_off(referrer); + SvWEAKREF_off(referrer); + 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 || + SvTYPE(referrer) == SVt_PVFM) { + if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ + /* You lookin' at me? */ + assert(CvSTASH(referrer)); + assert(CvSTASH(referrer) == (const HV *)sv); + SvANY(MUTABLE_CV(referrer))->xcv_stash = 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 ")", + (UV)SvFLAGS(referrer)); + } + + if (is_array) + *svp = NULL; + } + svp++; + } } if (is_array) { - AvFILLp(av) = -1; - SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ + AvFILLp(av) = -1; + SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ } return; } @@ -6362,30 +6362,30 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l } if (offset + len > curlen) { - SvGROW(bigstr, offset+len+1); - Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); - SvCUR_set(bigstr, offset+len); + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); } SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ - big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); - mid = big + offset + len; - midend = bigend = big + SvCUR(bigstr); - bigend += i; - *bigend = '\0'; - while (midend > mid) /* shove everything down */ - *--bigend = *--midend; - Move(little,big+offset,littlelen,char); - SvCUR_set(bigstr, SvCUR(bigstr) + i); - SvSETMAGIC(bigstr); - return; + big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); + mid = big + offset + len; + midend = bigend = big + SvCUR(bigstr); + bigend += i; + *bigend = '\0'; + while (midend > mid) /* shove everything down */ + *--bigend = *--midend; + Move(little,big+offset,littlelen,char); + SvCUR_set(bigstr, SvCUR(bigstr) + i); + SvSETMAGIC(bigstr); + return; } else if (i == 0) { - Move(little,SvPVX(bigstr)+offset,len,char); - SvSETMAGIC(bigstr); - return; + Move(little,SvPVX(bigstr)+offset,len,char); + SvSETMAGIC(bigstr); + return; } big = SvPVX(bigstr); @@ -6394,37 +6394,37 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l bigend = big + SvCUR(bigstr); if (midend > bigend) - Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", - midend, bigend); + Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", + midend, bigend); if (mid - big > bigend - midend) { /* faster to shorten from end */ - if (littlelen) { - Move(little, mid, littlelen,char); - mid += littlelen; - } - i = bigend - midend; - if (i > 0) { - Move(midend, mid, i,char); - mid += i; - } - *mid = '\0'; - SvCUR_set(bigstr, mid - big); + if (littlelen) { + Move(little, mid, littlelen,char); + mid += littlelen; + } + i = bigend - midend; + if (i > 0) { + Move(midend, mid, i,char); + mid += i; + } + *mid = '\0'; + SvCUR_set(bigstr, mid - big); } else if ((i = mid - big)) { /* faster from front */ - midend -= littlelen; - mid = midend; - Move(big, midend - i, i, char); - sv_chop(bigstr,midend-i); - if (littlelen) - Move(little, mid, littlelen,char); + midend -= littlelen; + mid = midend; + Move(big, midend - i, i, char); + sv_chop(bigstr,midend-i); + if (littlelen) + Move(little, mid, littlelen,char); } else if (littlelen) { - midend -= littlelen; - sv_chop(bigstr,midend); - Move(little,midend,littlelen,char); + midend -= littlelen; + sv_chop(bigstr,midend); + Move(little,midend,littlelen,char); } else { - sv_chop(bigstr,midend); + sv_chop(bigstr,midend); } SvSETMAGIC(bigstr); } @@ -6451,18 +6451,18 @@ Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1) { - Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" - " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" + " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); } if (SvMAGICAL(sv)) { - if (SvMAGICAL(nsv)) - mg_free(nsv); - else - sv_upgrade(nsv, SVt_PVMG); - SvMAGIC_set(nsv, SvMAGIC(sv)); - SvFLAGS(nsv) |= SvMAGICAL(sv); - SvMAGICAL_off(sv); - SvMAGIC_set(sv, NULL); + if (SvMAGICAL(nsv)) + mg_free(nsv); + else + sv_upgrade(nsv, SVt_PVMG); + SvMAGIC_set(nsv, SvMAGIC(sv)); + SvFLAGS(nsv) |= SvMAGICAL(sv); + SvMAGICAL_off(sv); + SvMAGIC_set(sv, NULL); } SvREFCNT(sv) = 0; sv_clear(sv); @@ -6476,7 +6476,7 @@ Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) StructCopy(nsv,sv,SV); #endif if(SvTYPE(sv) == SVt_IV) { - SET_SVANY_FOR_BODYLESS_IV(sv); + SET_SVANY_FOR_BODYLESS_IV(sv); } @@ -6508,8 +6508,8 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) /* will the CV shortly be freed by gp_free() ? */ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) { - SvANY(cv)->xcv_gv_u.xcv_gv = NULL; - return; + SvANY(cv)->xcv_gv_u.xcv_gv = NULL; + return; } /* if not, anonymise: */ @@ -6560,146 +6560,146 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) while (sv) { - type = SvTYPE(sv); - - assert(SvREFCNT(sv) == 0); - assert(SvTYPE(sv) != (svtype)SVTYPEMASK); - - if (type <= SVt_IV) { - /* See the comment in sv.h about the collusion between this - * early return and the overloading of the NULL slots in the - * size table. */ - if (SvROK(sv)) - goto free_rv; - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - goto free_head; - } - - /* objs are always >= MG, but pad names use the SVs_OBJECT flag - for another purpose */ - assert(!SvOBJECT(sv) || type >= SVt_PVMG); - - if (type >= SVt_PVMG) { - if (SvOBJECT(sv)) { - if (!curse(sv, 1)) goto get_next_sv; - type = SvTYPE(sv); /* destructor may have changed it */ - } - /* Free back-references before magic, in case the magic calls - * Perl code that has weak references to sv. */ - if (type == SVt_PVHV) { - Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); - if (SvMAGIC(sv)) - mg_free(sv); - } - else if (SvMAGIC(sv)) { - /* Free back-references before other types of magic. */ - sv_unmagic(sv, PERL_MAGIC_backref); - mg_free(sv); - } - SvMAGICAL_off(sv); - } - switch (type) { - /* case SVt_INVLIST: */ - case SVt_PVIO: - if (IoIFP(sv) && - IoIFP(sv) != PerlIO_stdin() && - IoIFP(sv) != PerlIO_stdout() && - IoIFP(sv) != PerlIO_stderr() && - !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - { - io_close(MUTABLE_IO(sv), NULL, FALSE, - (IoTYPE(sv) == IoTYPE_WRONLY || - IoTYPE(sv) == IoTYPE_RDWR || - IoTYPE(sv) == IoTYPE_APPEND)); - } - if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - PerlDir_close(IoDIRP(sv)); - IoDIRP(sv) = (DIR*)NULL; - Safefree(IoTOP_NAME(sv)); - Safefree(IoFMT_NAME(sv)); - Safefree(IoBOTTOM_NAME(sv)); - if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; - goto freescalar; - case SVt_REGEXP: - /* FIXME for plugins */ - pregfree2((REGEXP*) sv); - goto freescalar; - case SVt_PVCV: - case SVt_PVFM: - cv_undef(MUTABLE_CV(sv)); - /* If we're in a stash, we don't own a reference to it. - * However it does have a back reference to us, which needs to - * be cleared. */ - if ((stash = CvSTASH(sv))) - sv_del_backref(MUTABLE_SV(stash), sv); - goto freescalar; - case SVt_PVHV: - if (HvTOTALKEYS((HV*)sv) > 0) { - const HEK *hek; - /* this statement should match the one at the beginning of - * hv_undef_flags() */ - if ( PL_phase != PERL_PHASE_DESTRUCT - && (hek = HvNAME_HEK((HV*)sv))) - { - if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ - "sv_clear clearing PL_stashcache for '%" HEKf - "'\n", - HEKfARG(hek))); - (void)hv_deletehek(PL_stashcache, + type = SvTYPE(sv); + + assert(SvREFCNT(sv) == 0); + assert(SvTYPE(sv) != (svtype)SVTYPEMASK); + + if (type <= SVt_IV) { + /* See the comment in sv.h about the collusion between this + * early return and the overloading of the NULL slots in the + * size table. */ + if (SvROK(sv)) + goto free_rv; + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + goto free_head; + } + + /* objs are always >= MG, but pad names use the SVs_OBJECT flag + for another purpose */ + assert(!SvOBJECT(sv) || type >= SVt_PVMG); + + if (type >= SVt_PVMG) { + if (SvOBJECT(sv)) { + if (!curse(sv, 1)) goto get_next_sv; + type = SvTYPE(sv); /* destructor may have changed it */ + } + /* Free back-references before magic, in case the magic calls + * Perl code that has weak references to sv. */ + if (type == SVt_PVHV) { + Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + if (SvMAGIC(sv)) + mg_free(sv); + } + else if (SvMAGIC(sv)) { + /* Free back-references before other types of magic. */ + sv_unmagic(sv, PERL_MAGIC_backref); + mg_free(sv); + } + SvMAGICAL_off(sv); + } + switch (type) { + /* case SVt_INVLIST: */ + case SVt_PVIO: + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && + IoIFP(sv) != PerlIO_stdout() && + IoIFP(sv) != PerlIO_stderr() && + !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + { + io_close(MUTABLE_IO(sv), NULL, FALSE, + (IoTYPE(sv) == IoTYPE_WRONLY || + IoTYPE(sv) == IoTYPE_RDWR || + IoTYPE(sv) == IoTYPE_APPEND)); + } + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = (DIR*)NULL; + Safefree(IoTOP_NAME(sv)); + Safefree(IoFMT_NAME(sv)); + Safefree(IoBOTTOM_NAME(sv)); + if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; + goto freescalar; + case SVt_REGEXP: + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); + goto freescalar; + case SVt_PVCV: + case SVt_PVFM: + cv_undef(MUTABLE_CV(sv)); + /* If we're in a stash, we don't own a reference to it. + * However it does have a back reference to us, which needs to + * be cleared. */ + if ((stash = CvSTASH(sv))) + sv_del_backref(MUTABLE_SV(stash), sv); + goto freescalar; + case SVt_PVHV: + if (HvTOTALKEYS((HV*)sv) > 0) { + const HEK *hek; + /* this statement should match the one at the beginning of + * hv_undef_flags() */ + if ( PL_phase != PERL_PHASE_DESTRUCT + && (hek = HvNAME_HEK((HV*)sv))) + { + if (PL_stashcache) { + DEBUG_o(Perl_deb(aTHX_ + "sv_clear clearing PL_stashcache for '%" HEKf + "'\n", + HEKfARG(hek))); + (void)hv_deletehek(PL_stashcache, hek, G_DISCARD); } - hv_name_set((HV*)sv, NULL, 0, 0); - } - - /* save old iter_sv in unused SvSTASH field */ - assert(!SvOBJECT(sv)); - SvSTASH(sv) = (HV*)iter_sv; - iter_sv = sv; - - /* save old hash_index in unused SvMAGIC field */ - assert(!SvMAGICAL(sv)); - assert(!SvMAGIC(sv)); - ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; - hash_index = 0; - - next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); - goto get_next_sv; /* process this new sv */ - } - /* free empty hash */ - Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); - assert(!HvARRAY((HV*)sv)); - break; - case SVt_PVAV: - { - AV* av = MUTABLE_AV(sv); - if (PL_comppad == av) { - PL_comppad = NULL; - PL_curpad = NULL; - } - if (AvREAL(av) && AvFILLp(av) > -1) { - next_sv = AvARRAY(av)[AvFILLp(av)--]; - /* save old iter_sv in top-most slot of AV, - * and pray that it doesn't get wiped in the meantime */ - AvARRAY(av)[AvMAX(av)] = iter_sv; - iter_sv = sv; - goto get_next_sv; /* process this new sv */ - } - Safefree(AvALLOC(av)); - } - - break; - case SVt_PVLV: - if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ - SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); - HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; - PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); - } - else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ - SvREFCNT_dec(LvTARG(sv)); - if (isREGEXP(sv)) { + hv_name_set((HV*)sv, NULL, 0, 0); + } + + /* save old iter_sv in unused SvSTASH field */ + assert(!SvOBJECT(sv)); + SvSTASH(sv) = (HV*)iter_sv; + iter_sv = sv; + + /* save old hash_index in unused SvMAGIC field */ + assert(!SvMAGICAL(sv)); + assert(!SvMAGIC(sv)); + ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; + hash_index = 0; + + next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); + goto get_next_sv; /* process this new sv */ + } + /* free empty hash */ + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); + break; + case SVt_PVAV: + { + AV* av = MUTABLE_AV(sv); + if (PL_comppad == av) { + PL_comppad = NULL; + PL_curpad = NULL; + } + if (AvREAL(av) && AvFILLp(av) > -1) { + next_sv = AvARRAY(av)[AvFILLp(av)--]; + /* save old iter_sv in top-most slot of AV, + * and pray that it doesn't get wiped in the meantime */ + AvARRAY(av)[AvMAX(av)] = iter_sv; + iter_sv = sv; + goto get_next_sv; /* process this new sv */ + } + Safefree(AvALLOC(av)); + } + + break; + case SVt_PVLV: + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); + if (isREGEXP(sv)) { /* SvLEN points to a regex body. Free the body, then * set SvLEN to whatever value was in the now-freed * regex body. The PVX buffer is shared by multiple re's @@ -6710,188 +6710,188 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto freescalar; } /* FALLTHROUGH */ - case SVt_PVGV: - if (isGV_with_GP(sv)) { - if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) - && HvENAME_get(stash)) - mro_method_changed_in(stash); - gp_free(MUTABLE_GV(sv)); - if (GvNAME_HEK(sv)) - unshare_hek(GvNAME_HEK(sv)); - /* If we're in a stash, we don't own a reference to it. - * However it does have a back reference to us, which - * needs to be cleared. */ - if ((stash = GvSTASH(sv))) - sv_del_backref(MUTABLE_SV(stash), sv); - } - /* FIXME. There are probably more unreferenced pointers to SVs - * in the interpreter struct that we should check and tidy in - * a similar fashion to this: */ - /* See also S_sv_unglob, which does the same thing. */ - if ((const GV *)sv == PL_last_in_gv) - PL_last_in_gv = NULL; - else if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; + case SVt_PVGV: + if (isGV_with_GP(sv)) { + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvENAME_get(stash)) + mro_method_changed_in(stash); + gp_free(MUTABLE_GV(sv)); + if (GvNAME_HEK(sv)) + unshare_hek(GvNAME_HEK(sv)); + /* If we're in a stash, we don't own a reference to it. + * However it does have a back reference to us, which + * needs to be cleared. */ + if ((stash = GvSTASH(sv))) + sv_del_backref(MUTABLE_SV(stash), sv); + } + /* FIXME. There are probably more unreferenced pointers to SVs + * in the interpreter struct that we should check and tidy in + * a similar fashion to this: */ + /* See also S_sv_unglob, which does the same thing. */ + if ((const GV *)sv == PL_last_in_gv) + PL_last_in_gv = NULL; + else if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; else if ((const GV *)sv == PL_stderrgv) PL_stderrgv = NULL; /* FALLTHROUGH */ - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: - case SVt_INVLIST: - case SVt_PV: - freescalar: - /* Don't bother with SvOOK_off(sv); as we're only going to - * free it. */ - if (SvOOK(sv)) { - STRLEN offset; - SvOOK_offset(sv, offset); - SvPV_set(sv, SvPVX_mutable(sv) - offset); - /* Don't even bother with turning off the OOK flag. */ - } - if (SvROK(sv)) { - free_rv: - { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - next_sv = target; - } - } + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: + case SVt_INVLIST: + case SVt_PV: + freescalar: + /* Don't bother with SvOOK_off(sv); as we're only going to + * free it. */ + if (SvOOK(sv)) { + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); + /* Don't even bother with turning off the OOK flag. */ + } + if (SvROK(sv)) { + free_rv: + { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + next_sv = target; + } + } #ifdef PERL_ANY_COW - else if (SvPVX_const(sv) - && !(SvTYPE(sv) == SVt_PVIO - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) - { - if (SvIsCOW(sv)) { + else if (SvPVX_const(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + { + if (SvIsCOW(sv)) { #ifdef DEBUGGING - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); - sv_dump(sv); - } + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); + sv_dump(sv); + } #endif - if (SvLEN(sv)) { - if (CowREFCNT(sv)) { - sv_buf_to_rw(sv); - CowREFCNT(sv)--; - sv_buf_to_ro(sv); - SvLEN_set(sv, 0); - } - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); - } - - } - if (SvLEN(sv)) { - Safefree(SvPVX_mutable(sv)); - } - } + if (SvLEN(sv)) { + if (CowREFCNT(sv)) { + sv_buf_to_rw(sv); + CowREFCNT(sv)--; + sv_buf_to_ro(sv); + SvLEN_set(sv, 0); + } + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + + } + if (SvLEN(sv)) { + Safefree(SvPVX_mutable(sv)); + } + } #else - else if (SvPVX_const(sv) && SvLEN(sv) - && !(SvTYPE(sv) == SVt_PVIO - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) - Safefree(SvPVX_mutable(sv)); - else if (SvPVX_const(sv) && SvIsCOW(sv)) { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); - } + else if (SvPVX_const(sv) && SvLEN(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + Safefree(SvPVX_mutable(sv)); + else if (SvPVX_const(sv) && SvIsCOW(sv)) { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } #endif - break; - case SVt_NV: - break; - } + break; + case SVt_NV: + break; + } free_body: - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; - sv_type_details = bodies_by_type + type; - if (sv_type_details->arena) { - del_body(((char *)SvANY(sv) + sv_type_details->offset), - &PL_body_roots[type]); - } - else if (sv_type_details->body_size) { - safefree(SvANY(sv)); - } + sv_type_details = bodies_by_type + type; + if (sv_type_details->arena) { + del_body(((char *)SvANY(sv) + sv_type_details->offset), + &PL_body_roots[type]); + } + else if (sv_type_details->body_size) { + safefree(SvANY(sv)); + } free_head: - /* caller is responsible for freeing the head of the original sv */ - if (sv != orig_sv && !SvREFCNT(sv)) - del_SV(sv); + /* caller is responsible for freeing the head of the original sv */ + if (sv != orig_sv && !SvREFCNT(sv)) + del_SV(sv); - /* grab and free next sv, if any */ + /* grab and free next sv, if any */ get_next_sv: - while (1) { - sv = NULL; - if (next_sv) { - sv = next_sv; - next_sv = NULL; - } - else if (!iter_sv) { - break; - } else if (SvTYPE(iter_sv) == SVt_PVAV) { - AV *const av = (AV*)iter_sv; - if (AvFILLp(av) > -1) { - sv = AvARRAY(av)[AvFILLp(av)--]; - } - else { /* no more elements of current AV to free */ - sv = iter_sv; - type = SvTYPE(sv); - /* restore previous value, squirrelled away */ - iter_sv = AvARRAY(av)[AvMAX(av)]; - Safefree(AvALLOC(av)); - goto free_body; - } - } else if (SvTYPE(iter_sv) == SVt_PVHV) { - sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); - if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { - /* no more elements of current HV to free */ - sv = iter_sv; - type = SvTYPE(sv); - /* Restore previous values of iter_sv and hash_index, - * squirrelled away */ - assert(!SvOBJECT(sv)); - iter_sv = (SV*)SvSTASH(sv); - assert(!SvMAGICAL(sv)); - hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; + while (1) { + sv = NULL; + if (next_sv) { + sv = next_sv; + next_sv = NULL; + } + else if (!iter_sv) { + break; + } else if (SvTYPE(iter_sv) == SVt_PVAV) { + AV *const av = (AV*)iter_sv; + if (AvFILLp(av) > -1) { + sv = AvARRAY(av)[AvFILLp(av)--]; + } + else { /* no more elements of current AV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* restore previous value, squirrelled away */ + iter_sv = AvARRAY(av)[AvMAX(av)]; + Safefree(AvALLOC(av)); + goto free_body; + } + } else if (SvTYPE(iter_sv) == SVt_PVHV) { + sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); + if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { + /* no more elements of current HV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* Restore previous values of iter_sv and hash_index, + * squirrelled away */ + assert(!SvOBJECT(sv)); + iter_sv = (SV*)SvSTASH(sv); + assert(!SvMAGICAL(sv)); + hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; #ifdef DEBUGGING - /* perl -DA does not like rubbish in SvMAGIC. */ - SvMAGIC_set(sv, 0); + /* perl -DA does not like rubbish in SvMAGIC. */ + SvMAGIC_set(sv, 0); #endif - /* free any remaining detritus from the hash struct */ - Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); - assert(!HvARRAY((HV*)sv)); - goto free_body; - } - } - - /* unrolled SvREFCNT_dec and sv_free2 follows: */ - - if (!sv) - continue; - if (!SvREFCNT(sv)) { - sv_free(sv); - continue; - } - if (--(SvREFCNT(sv))) - continue; + /* free any remaining detritus from the hash struct */ + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); + goto free_body; + } + } + + /* unrolled SvREFCNT_dec and sv_free2 follows: */ + + if (!sv) + continue; + if (!SvREFCNT(sv)) { + sv_free(sv); + continue; + } + if (--(SvREFCNT(sv))) + continue; #ifdef DEBUGGING - if (SvTEMP(sv)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), - "Attempt to free temp prematurely: SV 0x%" UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); - continue; - } + if (SvTEMP(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%" UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + continue; + } #endif - if (SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = SvREFCNT_IMMORTAL; - continue; - } - break; - } /* while 1 */ + if (SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = SvREFCNT_IMMORTAL; + continue; + } + break; + } /* while 1 */ } /* while sv */ } @@ -6905,18 +6905,18 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { assert(SvOBJECT(sv)); if (PL_defstash && /* Still have a symbol table? */ - SvDESTROYABLE(sv)) + SvDESTROYABLE(sv)) { - dSP; - HV* stash; - do { - stash = SvSTASH(sv); - assert(SvTYPE(stash) == SVt_PVHV); - if (HvNAME(stash)) { - CV* destructor = NULL; + dSP; + HV* stash; + do { + stash = SvSTASH(sv); + assert(SvTYPE(stash) == SVt_PVHV); + if (HvNAME(stash)) { + CV* destructor = NULL; struct mro_meta *meta; - assert (SvOOK(stash)); + assert (SvOOK(stash)); DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n", HvNAME(stash)) ); @@ -6931,9 +6931,9 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { } else { bool autoload = FALSE; - GV *gv = + GV *gv = gv_fetchmeth_pvn(stash, S_destroy, S_destroy_len, -1, 0); - if (gv) + if (gv) destructor = GvCV(gv); if (!destructor) { gv = gv_autoload_pvn(stash, S_destroy, S_destroy_len, @@ -6957,68 +6957,68 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { DEBUG_o( Perl_deb(aTHX_ "Not caching AUTOLOAD for DESTROY method for %s\n", HvNAME(stash)) ); } - } - assert(!destructor || SvTYPE(destructor) == SVt_PVCV); - if (destructor - /* A constant subroutine can have no side effects, so - don't bother calling it. */ - && !CvCONST(destructor) - /* Don't bother calling an empty destructor or one that - returns immediately. */ - && (CvISXSUB(destructor) - || (CvSTART(destructor) - && (CvSTART(destructor)->op_next->op_type - != OP_LEAVESUB) - && (CvSTART(destructor)->op_next->op_type - != OP_PUSHMARK - || CvSTART(destructor)->op_next->op_next->op_type - != OP_RETURN - ) - )) - ) - { - SV* const tmpref = newRV(sv); - SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ - ENTER; - PUSHSTACKi(PERLSI_DESTROY); - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(tmpref); - PUTBACK; - call_sv(MUTABLE_SV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - POPSTACK; - SPAGAIN; - LEAVE; - if(SvREFCNT(tmpref) < 2) { - /* tmpref is not kept alive! */ - SvREFCNT(sv)--; - SvRV_set(tmpref, NULL); - SvROK_off(tmpref); - } - SvREFCNT_dec_NN(tmpref); - } - } - } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - - - if (check_refcnt && SvREFCNT(sv)) { - if (PL_in_clean_objs) - Perl_croak(aTHX_ - "DESTROY created new reference to dead object '%" HEKf "'", - HEKfARG(HvNAME_HEK(stash))); - /* DESTROY gave object new lease on life */ - return FALSE; - } + } + assert(!destructor || SvTYPE(destructor) == SVt_PVCV); + if (destructor + /* A constant subroutine can have no side effects, so + don't bother calling it. */ + && !CvCONST(destructor) + /* Don't bother calling an empty destructor or one that + returns immediately. */ + && (CvISXSUB(destructor) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type + != OP_LEAVESUB) + && (CvSTART(destructor)->op_next->op_type + != OP_PUSHMARK + || CvSTART(destructor)->op_next->op_next->op_type + != OP_RETURN + ) + )) + ) + { + SV* const tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(tmpref); + PUTBACK; + call_sv(MUTABLE_SV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + POPSTACK; + SPAGAIN; + LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV_set(tmpref, NULL); + SvROK_off(tmpref); + } + SvREFCNT_dec_NN(tmpref); + } + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + + if (check_refcnt && SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ + "DESTROY created new reference to dead object '%" HEKf "'", + HEKfARG(HvNAME_HEK(stash))); + /* DESTROY gave object new lease on life */ + return FALSE; + } } if (SvOBJECT(sv)) { - HV * const stash = SvSTASH(sv); - /* Curse before freeing the stash, as freeing the stash could cause - a recursive call into S_curse. */ - SvOBJECT_off(sv); /* Curse the object. */ - SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ - SvREFCNT_dec(stash); /* possibly of changed persuasion */ + HV * const stash = SvSTASH(sv); + /* Curse before freeing the stash, as freeing the stash could cause + a recursive call into S_curse. */ + SvOBJECT_off(sv); /* Curse the object. */ + SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ + SvREFCNT_dec(stash); /* possibly of changed persuasion */ } return TRUE; } @@ -7037,7 +7037,7 @@ Perl_sv_newref(pTHX_ SV *const sv) { PERL_UNUSED_CONTEXT; if (sv) - (SvREFCNT(sv))++; + (SvREFCNT(sv))++; return sv; } @@ -7149,7 +7149,7 @@ Perl_sv_len(pTHX_ SV *const sv) STRLEN len; if (!sv) - return 0; + return 0; (void)SvPV_const(sv, len); return len; @@ -7177,7 +7177,7 @@ STRLEN Perl_sv_len_utf8(pTHX_ SV *const sv) { if (!sv) - return 0; + return 0; SvGETMAGIC(sv); return sv_len_utf8_nomg(sv); @@ -7192,31 +7192,31 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; if (PL_utf8cache && SvUTF8(sv)) { - STRLEN ulen; - MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; - - if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { - if (mg->mg_len != -1) - ulen = mg->mg_len; - else { - /* We can use the offset cache for a headstart. - The longer value is stored in the first pair. */ - STRLEN *cache = (STRLEN *) mg->mg_ptr; - - ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], - s + len); - } - - if (PL_utf8cache < 0) { - const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); - assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); - } - } - else { - ulen = Perl_utf8_length(aTHX_ s, s + len); - utf8_mg_len_cache_update(sv, &mg, ulen); - } - return ulen; + STRLEN ulen; + MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + + if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { + if (mg->mg_len != -1) + ulen = mg->mg_len; + else { + /* We can use the offset cache for a headstart. + The longer value is stored in the first pair. */ + STRLEN *cache = (STRLEN *) mg->mg_ptr; + + ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], + s + len); + } + + if (PL_utf8cache < 0) { + const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); + assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); + } + } + else { + ulen = Perl_utf8_length(aTHX_ s, s + len); + utf8_mg_len_cache_update(sv, &mg, ulen); + } + return ulen; } return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len; } @@ -7225,7 +7225,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) offset. */ static STRLEN S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, - STRLEN *const uoffset_p, bool *const at_end) + STRLEN *const uoffset_p, bool *const at_end) { const U8 *s = start; STRLEN uoffset = *uoffset_p; @@ -7233,17 +7233,17 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; while (s < send && uoffset) { - --uoffset; - s += UTF8SKIP(s); + --uoffset; + s += UTF8SKIP(s); } if (s == send) { - *at_end = TRUE; + *at_end = TRUE; } else if (s > send) { - *at_end = TRUE; - /* This is the existing behaviour. Possibly it should be a croak, as - it's actually a bounds error */ - s = send; + *at_end = TRUE; + /* This is the existing behaviour. Possibly it should be a croak, as + it's actually a bounds error */ + s = send; } *uoffset_p -= uoffset; return s - start; @@ -7254,30 +7254,30 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, the passed in UTF-8 offset. */ static STRLEN S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, - STRLEN uoffset, const STRLEN uend) + STRLEN uoffset, const STRLEN uend) { STRLEN backw = uend - uoffset; PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY; if (uoffset < 2 * backw) { - /* The assumption is that going forwards is twice the speed of going - forward (that's where the 2 * backw comes from). - (The real figure of course depends on the UTF-8 data.) */ - const U8 *s = start; + /* The assumption is that going forwards is twice the speed of going + forward (that's where the 2 * backw comes from). + (The real figure of course depends on the UTF-8 data.) */ + const U8 *s = start; - while (s < send && uoffset--) - s += UTF8SKIP(s); - assert (s <= send); - if (s > send) - s = send; - return s - start; + while (s < send && uoffset--) + s += UTF8SKIP(s); + assert (s <= send); + if (s > send) + s = send; + return s - start; } while (backw--) { - send--; - while (UTF8_IS_CONTINUATION(*send)) - send--; + send--; + while (UTF8_IS_CONTINUATION(*send)) + send--; } return send - start; } @@ -7292,8 +7292,8 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, created if necessary, and the found value offered to it for update. */ static STRLEN S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, - const U8 *const send, STRLEN uoffset, - STRLEN uoffset0, STRLEN boffset0) + const U8 *const send, STRLEN uoffset, + STRLEN uoffset0, STRLEN boffset0) { STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ bool found = FALSE; @@ -7304,96 +7304,96 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start assert (uoffset >= uoffset0); if (!uoffset) - return 0; + return 0; if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv) - && PL_utf8cache - && (*mgp || (SvTYPE(sv) >= SVt_PVMG && - (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { - if ((*mgp)->mg_ptr) { - STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; - if (cache[0] == uoffset) { - /* An exact match. */ - return cache[1]; - } - if (cache[2] == uoffset) { - /* An exact match. */ - return cache[3]; - } - - if (cache[0] < uoffset) { - /* The cache already knows part of the way. */ - if (cache[0] > uoffset0) { - /* The cache knows more than the passed in pair */ - uoffset0 = cache[0]; - boffset0 = cache[1]; - } - if ((*mgp)->mg_len != -1) { - /* And we know the end too. */ - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, send, - uoffset - uoffset0, - (*mgp)->mg_len - uoffset0); - } else { - uoffset -= uoffset0; - boffset = boffset0 - + sv_pos_u2b_forwards(start + boffset0, - send, &uoffset, &at_end); - uoffset += uoffset0; - } - } - else if (cache[2] < uoffset) { - /* We're between the two cache entries. */ - if (cache[2] > uoffset0) { - /* and the cache knows more than the passed in pair */ - uoffset0 = cache[2]; - boffset0 = cache[3]; - } - - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, - start + cache[1], - uoffset - uoffset0, - cache[0] - uoffset0); - } else { - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, - start + cache[3], - uoffset - uoffset0, - cache[2] - uoffset0); - } - found = TRUE; - } - else if ((*mgp)->mg_len != -1) { - /* If we can take advantage of a passed in offset, do so. */ - /* In fact, offset0 is either 0, or less than offset, so don't - need to worry about the other possibility. */ - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, send, - uoffset - uoffset0, - (*mgp)->mg_len - uoffset0); - found = TRUE; - } + && PL_utf8cache + && (*mgp || (SvTYPE(sv) >= SVt_PVMG && + (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { + if ((*mgp)->mg_ptr) { + STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; + if (cache[0] == uoffset) { + /* An exact match. */ + return cache[1]; + } + if (cache[2] == uoffset) { + /* An exact match. */ + return cache[3]; + } + + if (cache[0] < uoffset) { + /* The cache already knows part of the way. */ + if (cache[0] > uoffset0) { + /* The cache knows more than the passed in pair */ + uoffset0 = cache[0]; + boffset0 = cache[1]; + } + if ((*mgp)->mg_len != -1) { + /* And we know the end too. */ + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, send, + uoffset - uoffset0, + (*mgp)->mg_len - uoffset0); + } else { + uoffset -= uoffset0; + boffset = boffset0 + + sv_pos_u2b_forwards(start + boffset0, + send, &uoffset, &at_end); + uoffset += uoffset0; + } + } + else if (cache[2] < uoffset) { + /* We're between the two cache entries. */ + if (cache[2] > uoffset0) { + /* and the cache knows more than the passed in pair */ + uoffset0 = cache[2]; + boffset0 = cache[3]; + } + + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, + start + cache[1], + uoffset - uoffset0, + cache[0] - uoffset0); + } else { + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, + start + cache[3], + uoffset - uoffset0, + cache[2] - uoffset0); + } + found = TRUE; + } + else if ((*mgp)->mg_len != -1) { + /* If we can take advantage of a passed in offset, do so. */ + /* In fact, offset0 is either 0, or less than offset, so don't + need to worry about the other possibility. */ + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, send, + uoffset - uoffset0, + (*mgp)->mg_len - uoffset0); + found = TRUE; + } } if (!found || PL_utf8cache < 0) { - STRLEN real_boffset; - uoffset -= uoffset0; - real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, - send, &uoffset, &at_end); - uoffset += uoffset0; + STRLEN real_boffset; + uoffset -= uoffset0; + real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, + send, &uoffset, &at_end); + uoffset += uoffset0; - if (found && PL_utf8cache < 0) - assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, - real_boffset, sv); - boffset = real_boffset; + if (found && PL_utf8cache < 0) + assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, + real_boffset, sv); + boffset = real_boffset; } if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) { - if (at_end) - utf8_mg_len_cache_update(sv, mgp, uoffset); - else - utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); + if (at_end) + utf8_mg_len_cache_update(sv, mgp, uoffset); + else + utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); } return boffset; } @@ -7422,7 +7422,7 @@ C to handle magic. STRLEN Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, - U32 flags) + U32 flags) { const U8 *start; STRLEN len; @@ -7432,25 +7432,25 @@ Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, start = (U8*)SvPV_flags(sv, len, flags); if (len) { - const U8 * const send = start + len; - MAGIC *mg = NULL; - boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); - - if (lenp - && *lenp /* don't bother doing work for 0, as its bytes equivalent - is 0, and *lenp is already set to that. */) { - /* Convert the relative offset to absolute. */ - const STRLEN uoffset2 = uoffset + *lenp; - const STRLEN boffset2 - = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, - uoffset, boffset) - boffset; - - *lenp = boffset2; - } + const U8 * const send = start + len; + MAGIC *mg = NULL; + boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); + + if (lenp + && *lenp /* don't bother doing work for 0, as its bytes equivalent + is 0, and *lenp is already set to that. */) { + /* Convert the relative offset to absolute. */ + const STRLEN uoffset2 = uoffset + *lenp; + const STRLEN boffset2 + = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, + uoffset, boffset) - boffset; + + *lenp = boffset2; + } } else { - if (lenp) - *lenp = 0; - boffset = 0; + if (lenp) + *lenp = 0; + boffset = 0; } return boffset; @@ -7486,27 +7486,27 @@ Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp) PERL_ARGS_ASSERT_SV_POS_U2B; if (lenp) { - STRLEN ulen = (STRLEN)*lenp; - *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, - SV_GMAGIC|SV_CONST_RETURN); - *lenp = (I32)ulen; + STRLEN ulen = (STRLEN)*lenp; + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, + SV_GMAGIC|SV_CONST_RETURN); + *lenp = (I32)ulen; } else { - *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, - SV_GMAGIC|SV_CONST_RETURN); + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, + SV_GMAGIC|SV_CONST_RETURN); } } static void S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, - const STRLEN ulen) + const STRLEN ulen) { PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE; if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv)) - return; + return; if (!*mgp && (SvTYPE(sv) < SVt_PVMG || - !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); } assert(*mgp); @@ -7545,31 +7545,31 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; if (SvREADONLY(sv)) - return; + return; if (!*mgp && (SvTYPE(sv) < SVt_PVMG || - !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, - 0); - (*mgp)->mg_len = -1; + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, + 0); + (*mgp)->mg_len = -1; } assert(*mgp); if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { - Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); - (*mgp)->mg_ptr = (char *) cache; + Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + (*mgp)->mg_ptr = (char *) cache; } assert(cache); if (PL_utf8cache < 0 && SvPOKp(sv)) { - /* SvPOKp() because, if sv is a reference, then SvPVX() is actually - a pointer. Note that we no longer cache utf8 offsets on refer- - ences, but this check is still a good idea, for robustness. */ - const U8 *start = (const U8 *) SvPVX_const(sv); - const STRLEN realutf8 = utf8_length(start, start + byte); + /* SvPOKp() because, if sv is a reference, then SvPVX() is actually + a pointer. Note that we no longer cache utf8 offsets on refer- + ences, but this check is still a good idea, for robustness. */ + const U8 *start = (const U8 *) SvPVX_const(sv); + const STRLEN realutf8 = utf8_length(start, start + byte); - assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, - sv); + assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, + sv); } /* Cache is held with the later position first, to simplify the code @@ -7577,78 +7577,78 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b ASSERT_UTF8_CACHE(cache); if (cache[1] == 0) { - /* Cache is totally empty */ - cache[0] = utf8; - cache[1] = byte; + /* Cache is totally empty */ + cache[0] = utf8; + cache[1] = byte; } else if (cache[3] == 0) { - if (byte > cache[1]) { - /* New one is larger, so goes first. */ - cache[2] = cache[0]; - cache[3] = cache[1]; - cache[0] = utf8; - cache[1] = byte; - } else { - cache[2] = utf8; - cache[3] = byte; - } + if (byte > cache[1]) { + /* New one is larger, so goes first. */ + cache[2] = cache[0]; + cache[3] = cache[1]; + cache[0] = utf8; + cache[1] = byte; + } else { + cache[2] = utf8; + cache[3] = byte; + } } else { /* float casts necessary? XXX */ #define THREEWAY_SQUARE(a,b,c,d) \ - ((float)((d) - (c))) * ((float)((d) - (c))) \ - + ((float)((c) - (b))) * ((float)((c) - (b))) \ - + ((float)((b) - (a))) * ((float)((b) - (a))) - - /* Cache has 2 slots in use, and we know three potential pairs. - Keep the two that give the lowest RMS distance. Do the - calculation in bytes simply because we always know the byte - length. squareroot has the same ordering as the positive value, - so don't bother with the actual square root. */ - if (byte > cache[1]) { - /* New position is after the existing pair of pairs. */ - const float keep_earlier - = THREEWAY_SQUARE(0, cache[3], byte, blen); - const float keep_later - = THREEWAY_SQUARE(0, cache[1], byte, blen); - - if (keep_later < keep_earlier) { + ((float)((d) - (c))) * ((float)((d) - (c))) \ + + ((float)((c) - (b))) * ((float)((c) - (b))) \ + + ((float)((b) - (a))) * ((float)((b) - (a))) + + /* Cache has 2 slots in use, and we know three potential pairs. + Keep the two that give the lowest RMS distance. Do the + calculation in bytes simply because we always know the byte + length. squareroot has the same ordering as the positive value, + so don't bother with the actual square root. */ + if (byte > cache[1]) { + /* New position is after the existing pair of pairs. */ + const float keep_earlier + = THREEWAY_SQUARE(0, cache[3], byte, blen); + const float keep_later + = THREEWAY_SQUARE(0, cache[1], byte, blen); + + if (keep_later < keep_earlier) { cache[2] = cache[0]; cache[3] = cache[1]; - } + } cache[0] = utf8; cache[1] = byte; - } - else { - const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen); - float b, c, keep_earlier; - if (byte > cache[3]) { - /* New position is between the existing pair of pairs. */ - b = (float)cache[3]; - c = (float)byte; - } else { - /* New position is before the existing pair of pairs. */ - b = (float)byte; - c = (float)cache[3]; - } - keep_earlier = THREEWAY_SQUARE(0, b, c, blen); - if (byte > cache[3]) { - if (keep_later < keep_earlier) { - cache[2] = utf8; - cache[3] = byte; - } - else { - cache[0] = utf8; - cache[1] = byte; - } - } - else { - if (! (keep_later < keep_earlier)) { - cache[0] = cache[2]; - cache[1] = cache[3]; - } - cache[2] = utf8; - cache[3] = byte; - } - } + } + else { + const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen); + float b, c, keep_earlier; + if (byte > cache[3]) { + /* New position is between the existing pair of pairs. */ + b = (float)cache[3]; + c = (float)byte; + } else { + /* New position is before the existing pair of pairs. */ + b = (float)byte; + c = (float)cache[3]; + } + keep_earlier = THREEWAY_SQUARE(0, b, c, blen); + if (byte > cache[3]) { + if (keep_later < keep_earlier) { + cache[2] = utf8; + cache[3] = byte; + } + else { + cache[0] = utf8; + cache[1] = byte; + } + } + else { + if (! (keep_later < keep_earlier)) { + cache[0] = cache[2]; + cache[1] = cache[3]; + } + cache[2] = utf8; + cache[3] = byte; + } + } } ASSERT_UTF8_CACHE(cache); } @@ -7666,15 +7666,15 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; if (forw < 2 * backw) { - return utf8_length(s, target); + return utf8_length(s, target); } while (end > target) { - end--; - while (UTF8_IS_CONTINUATION(*end)) { - end--; - } - endu--; + end--; + while (UTF8_IS_CONTINUATION(*end)) { + end--; + } + endu--; } return endu; } @@ -7711,73 +7711,73 @@ Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags) s = (const U8*)SvPV_flags(sv, blen, flags); if (blen < offset) - Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf - ", byte=%" UVuf, (UV)blen, (UV)offset); + Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf + ", byte=%" UVuf, (UV)blen, (UV)offset); send = s + offset; if (!SvREADONLY(sv) - && PL_utf8cache - && SvTYPE(sv) >= SVt_PVMG - && (mg = mg_find(sv, PERL_MAGIC_utf8))) + && PL_utf8cache + && SvTYPE(sv) >= SVt_PVMG + && (mg = mg_find(sv, PERL_MAGIC_utf8))) { - if (mg->mg_ptr) { - STRLEN * const cache = (STRLEN *) mg->mg_ptr; - if (cache[1] == offset) { - /* An exact match. */ - return cache[0]; - } - if (cache[3] == offset) { - /* An exact match. */ - return cache[2]; - } - - if (cache[1] < offset) { - /* We already know part of the way. */ - if (mg->mg_len != -1) { - /* Actually, we know the end too. */ - len = cache[0] - + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, - s + blen, mg->mg_len - cache[0]); - } else { - len = cache[0] + utf8_length(s + cache[1], send); - } - } - else if (cache[3] < offset) { - /* We're between the two cached pairs, so we do the calculation - offset by the byte/utf-8 positions for the earlier pair, - then add the utf-8 characters from the string start to - there. */ - len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, - s + cache[1], cache[0] - cache[2]) - + cache[2]; - - } - else { /* cache[3] > offset */ - len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], - cache[2]); - - } - ASSERT_UTF8_CACHE(cache); - found = TRUE; - } else if (mg->mg_len != -1) { - len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); - found = TRUE; - } + if (mg->mg_ptr) { + STRLEN * const cache = (STRLEN *) mg->mg_ptr; + if (cache[1] == offset) { + /* An exact match. */ + return cache[0]; + } + if (cache[3] == offset) { + /* An exact match. */ + return cache[2]; + } + + if (cache[1] < offset) { + /* We already know part of the way. */ + if (mg->mg_len != -1) { + /* Actually, we know the end too. */ + len = cache[0] + + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, + s + blen, mg->mg_len - cache[0]); + } else { + len = cache[0] + utf8_length(s + cache[1], send); + } + } + else if (cache[3] < offset) { + /* We're between the two cached pairs, so we do the calculation + offset by the byte/utf-8 positions for the earlier pair, + then add the utf-8 characters from the string start to + there. */ + len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, + s + cache[1], cache[0] - cache[2]) + + cache[2]; + + } + else { /* cache[3] > offset */ + len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], + cache[2]); + + } + ASSERT_UTF8_CACHE(cache); + found = TRUE; + } else if (mg->mg_len != -1) { + len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); + found = TRUE; + } } if (!found || PL_utf8cache < 0) { - const STRLEN real_len = utf8_length(s, send); + const STRLEN real_len = utf8_length(s, send); - if (found && PL_utf8cache < 0) - assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); - len = real_len; + if (found && PL_utf8cache < 0) + assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); + len = real_len; } if (PL_utf8cache) { - if (blen == offset) - utf8_mg_len_cache_update(sv, &mg, len); - else - utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); + if (blen == offset) + utf8_mg_len_cache_update(sv, &mg, len); + else + utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); } return len; @@ -7808,29 +7808,29 @@ Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp) PERL_ARGS_ASSERT_SV_POS_B2U; if (!sv) - return; + return; *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp, - SV_GMAGIC|SV_CONST_RETURN); + SV_GMAGIC|SV_CONST_RETURN); } static void S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache, - STRLEN real, SV *const sv) + STRLEN real, SV *const sv) { PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT; /* As this is debugging only code, save space by keeping this test here, rather than inlining it in all the callers. */ if (from_cache == real) - return; + return; /* Need to turn the assertions off otherwise we may recurse infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; Perl_croak(aTHX_ "panic: %s cache %" UVuf " real %" UVuf " for %" SVf, - func, (UV) from_cache, (UV) real, SVfARG(sv)); + func, (UV) from_cache, (UV) real, SVfARG(sv)); } /* @@ -7858,46 +7858,46 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) STRLEN cur2; if (!sv1) { - pv1 = ""; - cur1 = 0; + pv1 = ""; + cur1 = 0; } else { - /* if pv1 and pv2 are the same, second SvPV_const call may - * invalidate pv1 (if we are handling magic), so we may need to - * make a copy */ - if (sv1 == sv2 && flags & SV_GMAGIC - && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { - pv1 = SvPV_const(sv1, cur1); - sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); - } - pv1 = SvPV_flags_const(sv1, cur1, flags); + /* if pv1 and pv2 are the same, second SvPV_const call may + * invalidate pv1 (if we are handling magic), so we may need to + * make a copy */ + if (sv1 == sv2 && flags & SV_GMAGIC + && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { + pv1 = SvPV_const(sv1, cur1); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); + } + pv1 = SvPV_flags_const(sv1, cur1, flags); } if (!sv2){ - pv2 = ""; - cur2 = 0; + pv2 = ""; + cur2 = 0; } else - pv2 = SvPV_flags_const(sv2, cur2, flags); + pv2 = SvPV_flags_const(sv2, cur2, flags); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. */ - if (SvUTF8(sv1)) { - /* sv1 is the UTF-8 one */ - return bytes_cmp_utf8((const U8*)pv2, cur2, - (const U8*)pv1, cur1) == 0; - } - else { - /* sv2 is the UTF-8 one */ - return bytes_cmp_utf8((const U8*)pv1, cur1, - (const U8*)pv2, cur2) == 0; - } + if (SvUTF8(sv1)) { + /* sv1 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1) == 0; + } + else { + /* sv2 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2) == 0; + } } if (cur1 == cur2) - return (pv1 == pv2) || memEQ(pv1, pv2, cur1); + return (pv1 == pv2) || memEQ(pv1, pv2, cur1); else - return 0; + return 0; } /* @@ -7927,7 +7927,7 @@ Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2) I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, - const U32 flags) + const U32 flags) { STRLEN cur1, cur2; const char *pv1, *pv2; @@ -7935,39 +7935,39 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, SV *svrecode = NULL; if (!sv1) { - pv1 = ""; - cur1 = 0; + pv1 = ""; + cur1 = 0; } else - pv1 = SvPV_flags_const(sv1, cur1, flags); + pv1 = SvPV_flags_const(sv1, cur1, flags); if (!sv2) { - pv2 = ""; - cur2 = 0; + pv2 = ""; + cur2 = 0; } else - pv2 = SvPV_flags_const(sv2, cur2, flags); + pv2 = SvPV_flags_const(sv2, cur2, flags); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. */ - if (SvUTF8(sv1)) { - const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, - (const U8*)pv1, cur1); - return retval ? retval < 0 ? -1 : +1 : 0; - } - else { - const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, - (const U8*)pv2, cur2); - return retval ? retval < 0 ? -1 : +1 : 0; - } + if (SvUTF8(sv1)) { + const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1); + return retval ? retval < 0 ? -1 : +1 : 0; + } + else { + const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2); + return retval ? retval < 0 ? -1 : +1 : 0; + } } /* Here, if both are non-NULL, then they have the same UTF8ness. */ if (!cur1) { - cmp = cur2 ? -1 : 0; + cmp = cur2 ? -1 : 0; } else if (!cur2) { - cmp = 1; + cmp = 1; } else { STRLEN shortest_len = cur1 < cur2 ? cur1 : cur2; @@ -8155,7 +8155,7 @@ Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2) I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, - const U32 flags) + const U32 flags) { #ifdef USE_LOCALE_COLLATE @@ -8164,7 +8164,7 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, I32 retval; if (PL_collation_standard) - goto raw_compare; + goto raw_compare; len1 = len2 = 0; @@ -8186,20 +8186,20 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, } if (!pv1 || !len1) { - if (pv2 && len2) - return -1; - else - goto raw_compare; + if (pv2 && len2) + return -1; + else + goto raw_compare; } else { - if (!pv2 || !len2) - return 1; + if (!pv2 || !len2) + return 1; } retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); if (retval) - return retval < 0 ? -1 : 1; + return retval < 0 ? -1 : 1; /* * When the result of collation is equality, that doesn't mean @@ -8252,39 +8252,39 @@ Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) /* If we don't have collation magic on 'sv', or the locale has changed * since the last time we calculated it, get it and save it now */ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { - const char *s; - char *xf; - STRLEN len, xlen; + const char *s; + char *xf; + STRLEN len, xlen; /* Free the old space */ - if (mg) - Safefree(mg->mg_ptr); - - s = SvPV_flags_const(sv, len, flags); - if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) { - if (! mg) { - mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, - 0, 0); - assert(mg); - } - mg->mg_ptr = xf; - mg->mg_len = xlen; - } - else { - if (mg) { - mg->mg_ptr = NULL; - mg->mg_len = -1; - } - } + if (mg) + Safefree(mg->mg_ptr); + + s = SvPV_flags_const(sv, len, flags); + if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) { + if (! mg) { + mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, + 0, 0); + assert(mg); + } + mg->mg_ptr = xf; + mg->mg_len = xlen; + } + else { + if (mg) { + mg->mg_ptr = NULL; + mg->mg_len = -1; + } + } } if (mg && mg->mg_ptr) { - *nxp = mg->mg_len; - return mg->mg_ptr + sizeof(PL_collation_ix); + *nxp = mg->mg_len; + return mg->mg_ptr + sizeof(PL_collation_ix); } else { - *nxp = 0; - return NULL; + *nxp = 0; + return NULL; } } @@ -8325,96 +8325,96 @@ S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) */ fd = PerlIO_fileno(fp); if (fd != -1 - && PerlLIO_fstat(fd, &st) == 0 - && (st.st_fab_rfm == FAB$C_VAR - || st.st_fab_rfm == FAB$C_VFC - || st.st_fab_rfm == FAB$C_FIX)) { + && PerlLIO_fstat(fd, &st) == 0 + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC + || st.st_fab_rfm == FAB$C_FIX)) { - bytesread = PerlLIO_read(fd, buffer, recsize); + bytesread = PerlLIO_read(fd, buffer, recsize); } else /* in-memory file from PerlIO::Scalar * or not a record-oriented file */ #endif { - bytesread = PerlIO_read(fp, buffer, recsize); - - /* At this point, the logic in sv_get() means that sv will - be treated as utf-8 if the handle is utf8. - */ - if (PerlIO_isutf8(fp) && bytesread > 0) { - char *bend = buffer + bytesread; - char *bufp = buffer; - size_t charcount = 0; - bool charstart = TRUE; - STRLEN skip = 0; - - while (charcount < recsize) { - /* count accumulated characters */ - while (bufp < bend) { - if (charstart) { - skip = UTF8SKIP(bufp); - } - if (bufp + skip > bend) { - /* partial at the end */ - charstart = FALSE; - break; - } - else { - ++charcount; - bufp += skip; - charstart = TRUE; - } - } - - if (charcount < recsize) { - STRLEN readsize; - STRLEN bufp_offset = bufp - buffer; - SSize_t morebytesread; - - /* originally I read enough to fill any incomplete - character and the first byte of the next - character if needed, but if there's many - multi-byte encoded characters we're going to be - making a read call for every character beyond - the original read size. - - So instead, read the rest of the character if - any, and enough bytes to match at least the - start bytes for each character we're going to - read. - */ - if (charstart) - readsize = recsize - charcount; - else - readsize = skip - (bend - bufp) + recsize - charcount - 1; - buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; - bend = buffer + bytesread; - morebytesread = PerlIO_read(fp, bend, readsize); - if (morebytesread <= 0) { - /* we're done, if we still have incomplete - characters the check code in sv_gets() will - warn about them. - - I'd originally considered doing - PerlIO_ungetc() on all but the lead - character of the incomplete character, but - read() doesn't do that, so I don't. - */ - break; - } - - /* prepare to scan some more */ - bytesread += morebytesread; - bend = buffer + bytesread; - bufp = buffer + bufp_offset; - } - } - } + bytesread = PerlIO_read(fp, buffer, recsize); + + /* At this point, the logic in sv_get() means that sv will + be treated as utf-8 if the handle is utf8. + */ + if (PerlIO_isutf8(fp) && bytesread > 0) { + char *bend = buffer + bytesread; + char *bufp = buffer; + size_t charcount = 0; + bool charstart = TRUE; + STRLEN skip = 0; + + while (charcount < recsize) { + /* count accumulated characters */ + while (bufp < bend) { + if (charstart) { + skip = UTF8SKIP(bufp); + } + if (bufp + skip > bend) { + /* partial at the end */ + charstart = FALSE; + break; + } + else { + ++charcount; + bufp += skip; + charstart = TRUE; + } + } + + if (charcount < recsize) { + STRLEN readsize; + STRLEN bufp_offset = bufp - buffer; + SSize_t morebytesread; + + /* originally I read enough to fill any incomplete + character and the first byte of the next + character if needed, but if there's many + multi-byte encoded characters we're going to be + making a read call for every character beyond + the original read size. + + So instead, read the rest of the character if + any, and enough bytes to match at least the + start bytes for each character we're going to + read. + */ + if (charstart) + readsize = recsize - charcount; + else + readsize = skip - (bend - bufp) + recsize - charcount - 1; + buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; + bend = buffer + bytesread; + morebytesread = PerlIO_read(fp, bend, readsize); + if (morebytesread <= 0) { + /* we're done, if we still have incomplete + characters the check code in sv_gets() will + warn about them. + + I'd originally considered doing + PerlIO_ungetc() on all but the lead + character of the incomplete character, but + read() doesn't do that, so I don't. + */ + break; + } + + /* prepare to scan some more */ + bytesread += morebytesread; + bend = buffer + bytesread; + bufp = buffer + bufp_offset; + } + } + } } if (bytesread < 0) - bytesread = 0; + bytesread = 0; SvCUR_set(sv, bytesread + append); buffer[bytesread] = '\0'; return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; @@ -8446,7 +8446,7 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) PERL_ARGS_ASSERT_SV_GETS; if (SvTHINKFIRST(sv)) - sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); + sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); /* XXX. If you make this PVIV, then copy on write can copy scalars read from <>. However, perlbench says it's slower, because the existing swipe code @@ -8456,14 +8456,14 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) if (append) { /* line is going to be appended to the existing buffer in the sv */ - if (PerlIO_isutf8(fp)) { - if (!SvUTF8(sv)) { - sv_utf8_upgrade_nomg(sv); - sv_pos_u2b(sv,&append,0); - } - } else if (SvUTF8(sv)) { - return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); - } + if (PerlIO_isutf8(fp)) { + if (!SvUTF8(sv)) { + sv_utf8_upgrade_nomg(sv); + sv_pos_u2b(sv,&append,0); + } + } else if (SvUTF8(sv)) { + return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); + } } SvPOK_only(sv); @@ -8473,58 +8473,58 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) SvCUR_set(sv,0); } if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); + SvUTF8_on(sv); if (IN_PERL_COMPILETIME) { - /* we always read code in line mode */ - rsptr = "\n"; - rslen = 1; + /* we always read code in line mode */ + rsptr = "\n"; + rslen = 1; } else if (RsSNARF(PL_rs)) { - /* If it is a regular disk file use size from stat() as estimate - of amount we are going to read -- may result in mallocing - more memory than we really need if the layers below reduce - the size we read (e.g. CRLF or a gzip layer). - */ - Stat_t st; + /* If it is a regular disk file use size from stat() as estimate + of amount we are going to read -- may result in mallocing + more memory than we really need if the layers below reduce + the size we read (e.g. CRLF or a gzip layer). + */ + Stat_t st; int fd = PerlIO_fileno(fp); - if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) { - const Off_t offset = PerlIO_tell(fp); - if (offset != (Off_t) -1 && st.st_size + append > offset) { + if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) { + const Off_t offset = PerlIO_tell(fp); + if (offset != (Off_t) -1 && st.st_size + append > offset) { #ifdef PERL_COPY_ON_WRITE /* Add an extra byte for the sake of copy-on-write's * buffer reference count. */ - (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); #else - (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); #endif - } - } - rsptr = NULL; - rslen = 0; + } + } + rsptr = NULL; + rslen = 0; } else if (RsRECORD(PL_rs)) { - return S_sv_gets_read_record(aTHX_ sv, fp, append); + return S_sv_gets_read_record(aTHX_ sv, fp, append); } else if (RsPARA(PL_rs)) { - rsptr = "\n\n"; - rslen = 2; - rspara = 1; + rsptr = "\n\n"; + rslen = 2; + rspara = 1; } else { - /* Get $/ i.e. PL_rs into same encoding as stream wants */ - if (PerlIO_isutf8(fp)) { - rsptr = SvPVutf8(PL_rs, rslen); - } - else { - if (SvUTF8(PL_rs)) { - if (!sv_utf8_downgrade(PL_rs, TRUE)) { - Perl_croak(aTHX_ "Wide character in $/"); - } - } + /* Get $/ i.e. PL_rs into same encoding as stream wants */ + if (PerlIO_isutf8(fp)) { + rsptr = SvPVutf8(PL_rs, rslen); + } + else { + if (SvUTF8(PL_rs)) { + if (!sv_utf8_downgrade(PL_rs, TRUE)) { + Perl_croak(aTHX_ "Wide character in $/"); + } + } /* extract the raw pointer to the record separator */ - rsptr = SvPV_const(PL_rs, rslen); - } + rsptr = SvPV_const(PL_rs, rslen); + } } /* rslast is the last character in the record separator @@ -8641,25 +8641,25 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) /* make sure we have the room */ if ((I32)(SvLEN(sv) - append) <= cnt + 1) { - /* Not room for all of it - if we are looking for a separator and room for some - */ - if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { - /* just process what we have room for */ - shortbuffered = cnt - SvLEN(sv) + append + 1; - cnt -= shortbuffered; - } - else { + /* Not room for all of it + if we are looking for a separator and room for some + */ + if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { + /* just process what we have room for */ + shortbuffered = cnt - SvLEN(sv) + append + 1; + cnt -= shortbuffered; + } + else { /* ensure that the target sv has enough room to hold * the rest of the read-ahead buffer */ - shortbuffered = 0; - /* remember that cnt can be negative */ - SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); - } + shortbuffered = 0; + /* remember that cnt can be negative */ + SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); + } } else { /* we have enough room to hold the full buffer, lets scream */ - shortbuffered = 0; + shortbuffered = 0; } /* extract the pointer to sv's string buffer, offset by append as necessary */ @@ -8669,19 +8669,19 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) /* some trace debug output */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" - UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" + UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: /* if there is stuff left in the read-ahead buffer */ - if (cnt > 0) { + if (cnt > 0) { /* if there is a separator */ - if (rslen) { + if (rslen) { /* find next rslast */ STDCHAR *p; @@ -8703,43 +8703,43 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) ptr += cnt; bp += cnt; cnt = 0; - } - else { + } + else { /* no separator, slurp the full buffer */ - Copy(ptr, bp, cnt, char); /* this | eat */ - bp += cnt; /* screams | dust */ - ptr += cnt; /* louder | sed :-) */ - cnt = 0; - assert (!shortbuffered); - goto cannot_be_shortbuffered; - } - } - - if (shortbuffered) { /* oh well, must extend */ + Copy(ptr, bp, cnt, char); /* this | eat */ + bp += cnt; /* screams | dust */ + ptr += cnt; /* louder | sed :-) */ + cnt = 0; + assert (!shortbuffered); + goto cannot_be_shortbuffered; + } + } + + if (shortbuffered) { /* oh well, must extend */ /* we didnt have enough room to fit the line into the target buffer * so we must extend the target buffer and keep going */ - cnt = shortbuffered; - shortbuffered = 0; - bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); + cnt = shortbuffered; + shortbuffered = 0; + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); /* extned the target sv's buffer so it can hold the full read-ahead buffer */ - SvGROW(sv, SvLEN(sv) + append + cnt + 2); - bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ - continue; - } + SvGROW(sv, SvLEN(sv) + append + cnt + 2); + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ + continue; + } cannot_be_shortbuffered: /* we need to refill the read-ahead buffer if possible */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n", - PTR2UV(ptr),(IV)cnt)); - PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n", + PTR2UV(ptr),(IV)cnt)); + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ - DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + DEBUG_Pv(PerlIO_printf(Perl_debug_log, + "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* call PerlIO_getc() to let it prefill the lookahead buffer @@ -8752,123 +8752,123 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) */ bpx = bp - (STDCHAR*)SvPVX_const(sv); /* signals might be called here, possibly modifying sv */ - i = PerlIO_getc(fp); /* get more characters */ + i = PerlIO_getc(fp); /* get more characters */ bp = (STDCHAR*)SvPVX_const(sv) + bpx; - DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + DEBUG_Pv(PerlIO_printf(Perl_debug_log, + "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* find out how much is left in the read-ahead buffer, and rextract its pointer */ - cnt = PerlIO_get_cnt(fp); - ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n", - PTR2UV(ptr),(IV)cnt)); + cnt = PerlIO_get_cnt(fp); + ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n", + PTR2UV(ptr),(IV)cnt)); - if (i == EOF) /* all done for ever? */ - goto thats_really_all_folks; + if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; /* make sure we have enough space in the target sv */ - bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); - SvGROW(sv, bpx + cnt + 2); - bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); + SvGROW(sv, bpx + cnt + 2); + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ /* copy of the char we got from getc() */ - *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ + *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ /* make sure we deal with the i being the last character of a separator */ - if (rslen && (STDCHAR)i == rslast) /* all done for now? */ - goto thats_all_folks; + if (rslen && (STDCHAR)i == rslast) /* all done for now? */ + goto thats_all_folks; } thats_all_folks: /* check if we have actually found the separator - only really applies * when rslen > 1 */ if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || - memNE((char*)bp - rslen, rsptr, rslen)) - goto screamer; /* go back to the fray */ + memNE((char*)bp - rslen, rsptr, rslen)) + goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) - cnt += shortbuffered; - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt)); + cnt += shortbuffered; + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf - "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf + "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: done, len=%ld, string=|%.*s|\n", - (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); + "Screamer: done, len=%ld, string=|%.*s|\n", + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); } else { /*The big, slow, and stupid way. */ - STDCHAR buf[8192]; + STDCHAR buf[8192]; screamer2: - if (rslen) { + if (rslen) { const STDCHAR * const bpe = buf + sizeof(buf); - bp = buf; - while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) - ; /* keep reading */ - cnt = bp - buf; - } - else { - cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); - /* Accommodate broken VAXC compiler, which applies U8 cast to - * both args of ?: operator, causing EOF to change into 255 - */ - if (cnt > 0) - i = (U8)buf[cnt - 1]; - else - i = EOF; - } - - if (cnt < 0) - cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ - if (append) + bp = buf; + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) + ; /* keep reading */ + cnt = bp - buf; + } + else { + cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); + /* Accommodate broken VAXC compiler, which applies U8 cast to + * both args of ?: operator, causing EOF to change into 255 + */ + if (cnt > 0) + i = (U8)buf[cnt - 1]; + else + i = EOF; + } + + if (cnt < 0) + cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ + if (append) sv_catpvn_nomg(sv, (char *) buf, cnt); - else + else sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */ - if (i != EOF && /* joy */ - (!rslen || - SvCUR(sv) < rslen || - memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) - { - append = -1; - /* - * If we're reading from a TTY and we get a short read, - * indicating that the user hit his EOF character, we need - * to notice it now, because if we try to read from the TTY - * again, the EOF condition will disappear. - * - * The comparison of cnt to sizeof(buf) is an optimization - * that prevents unnecessary calls to feof(). - * - * - jik 9/25/96 - */ - if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) - goto screamer2; - } + if (i != EOF && /* joy */ + (!rslen || + SvCUR(sv) < rslen || + memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + { + append = -1; + /* + * If we're reading from a TTY and we get a short read, + * indicating that the user hit his EOF character, we need + * to notice it now, because if we try to read from the TTY + * again, the EOF condition will disappear. + * + * The comparison of cnt to sizeof(buf) is an optimization + * that prevents unnecessary calls to feof(). + * + * - jik 9/25/96 + */ + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) + goto screamer2; + } } if (rspara) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ - i = PerlIO_getc(fp); - if (i != '\n') { - PerlIO_ungetc(fp,i); - break; - } - } + i = PerlIO_getc(fp); + if (i != '\n') { + PerlIO_ungetc(fp,i); + break; + } + } } return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; @@ -8891,7 +8891,7 @@ void Perl_sv_inc(pTHX_ SV *const sv) { if (!sv) - return; + return; SvGETMAGIC(sv); sv_inc_nomg(sv); } @@ -8903,52 +8903,52 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) int flags; if (!sv) - return; + return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) - return; - i = PTR2IV(SvRV(sv)); - sv_unref(sv); - sv_setiv(sv, i); - } - else sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv)) { + Perl_croak_no_modify(); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); + } + else sv_force_normal_flags(sv, 0); } flags = SvFLAGS(sv); if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { - /* It's (privately or publicly) a float, but not tested as an - integer, so test it to see. */ - (void) SvIV(sv); - flags = SvFLAGS(sv); + /* It's (privately or publicly) a float, but not tested as an + integer, so test it to see. */ + (void) SvIV(sv); + flags = SvFLAGS(sv); } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { - /* It's publicly an integer, or privately an integer-not-float */ + /* It's publicly an integer, or privately an integer-not-float */ #ifdef PERL_PRESERVE_IVUV oops_its_int: #endif - if (SvIsUV(sv)) { - if (SvUVX(sv) == UV_MAX) - sv_setnv(sv, UV_MAX_P1); + if (SvIsUV(sv)) { + if (SvUVX(sv) == UV_MAX) + sv_setnv(sv, UV_MAX_P1); else { - (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) + 1); + (void)SvIOK_only_UV(sv); + SvUV_set(sv, SvUVX(sv) + 1); } - } else { - if (SvIVX(sv) == IV_MAX) - sv_setuv(sv, (UV)IV_MAX + 1); - else { - (void)SvIOK_only(sv); - SvIV_set(sv, SvIVX(sv) + 1); - } - } - return; + } else { + if (SvIVX(sv) == IV_MAX) + sv_setuv(sv, (UV)IV_MAX + 1); + else { + (void)SvIOK_only(sv); + SvIV_set(sv, SvIVX(sv) + 1); + } + } + return; } if (flags & SVp_NOK) { - const NV was = SvNVX(sv); + const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT != 0.0 && /* If NVX was NaN, the following comparisons return always false */ UNLIKELY(was >= NV_OVERFLOWS_INTEGERS_AT || @@ -8959,14 +8959,14 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) LIKELY(!Perl_isinf(was)) #endif ) { - /* diag_listed_as: Lost precision when %s %f by 1 */ - Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when incrementing %" NVff " by 1", - was); - } - (void)SvNOK_only(sv); + /* diag_listed_as: Lost precision when %s %f by 1 */ + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); SvNV_set(sv, was + 1.0); - return; + return; } /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */ @@ -8974,88 +8974,88 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) Perl_croak_no_modify(); if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { - if ((flags & SVTYPEMASK) < SVt_PVIV) - sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); - (void)SvIOK_only(sv); - SvIV_set(sv, 1); - return; + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); + (void)SvIOK_only(sv); + SvIV_set(sv, 1); + return; } d = SvPVX(sv); while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (d < SvEND(sv)) { - const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); + const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); #ifdef PERL_PRESERVE_IVUV - /* Got to punt this as an integer if needs be, but we don't issue - warnings. Probably ought to make the sv_iv_please() that does - the conversion if possible, and silently. */ - if (numtype && !(numtype & IS_NUMBER_INFINITY)) { - /* Need to try really hard to see if it's an integer. - 9.22337203685478e+18 is an integer. - but "9.22337203685478e+18" + 0 is UV=9223372036854779904 - so $a="9.22337203685478e+18"; $a+0; $a++ - needs to be the same as $a="9.22337203685478e+18"; $a++ - or we go insane. */ - - (void) sv_2iv(sv); - if (SvIOK(sv)) - goto oops_its_int; - - /* sv_2iv *should* have made this an NV */ - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); + /* Got to punt this as an integer if needs be, but we don't issue + warnings. Probably ought to make the sv_iv_please() that does + the conversion if possible, and silently. */ + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a++ + needs to be the same as $a="9.22337203685478e+18"; $a++ + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); SvNV_set(sv, SvNVX(sv) + 1.0); - return; - } - /* I don't think we can get here. Maybe I should assert this - And if we do get here I suspect that sv_setnv will croak. NWC - Fall through. */ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); - } + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); + } #endif /* PERL_PRESERVE_IVUV */ if (!numtype && ckWARN(WARN_NUMERIC)) not_incrementable(sv); - sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); - return; + sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); + return; } d--; while (d >= SvPVX_const(sv)) { - if (isDIGIT(*d)) { - if (++*d <= '9') - return; - *(d--) = '0'; - } - else { + if (isDIGIT(*d)) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + else { #ifdef EBCDIC - /* MKS: The original code here died if letters weren't consecutive. - * at least it didn't have to worry about non-C locales. The - * new code assumes that ('z'-'a')==('Z'-'A'), letters are - * arranged in order (although not consecutively) and that only - * [A-Za-z] are accepted by isALPHA in the C locale. - */ - if (isALPHA_FOLD_NE(*d, 'z')) { - do { ++*d; } while (!isALPHA(*d)); - return; - } - *(d--) -= 'z' - 'a'; + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (isALPHA_FOLD_NE(*d, 'z')) { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; #else - ++*d; - if (isALPHA(*d)) - return; - *(d--) -= 'z' - 'a' + 1; + ++*d; + if (isALPHA(*d)) + return; + *(d--) -= 'z' - 'a' + 1; #endif - } + } } /* oh,oh, the number grew */ SvGROW(sv, SvCUR(sv) + 2); SvCUR_set(sv, SvCUR(sv) + 1); for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) - *d = d[-1]; + *d = d[-1]; if (isDIGIT(d[1])) - *d = '1'; + *d = '1'; else - *d = d[1]; + *d = d[1]; } /* @@ -9076,7 +9076,7 @@ void Perl_sv_dec(pTHX_ SV *const sv) { if (!sv) - return; + return; SvGETMAGIC(sv); sv_dec_nomg(sv); } @@ -9087,54 +9087,54 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) int flags; if (!sv) - return; + return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) - return; - i = PTR2IV(SvRV(sv)); - sv_unref(sv); - sv_setiv(sv, i); - } - else sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv)) { + Perl_croak_no_modify(); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); + } + else sv_force_normal_flags(sv, 0); } /* Unlike sv_inc we don't have to worry about string-never-numbers and keeping them magic. But we mustn't warn on punting */ flags = SvFLAGS(sv); if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { - /* It's publicly an integer, or privately an integer-not-float */ + /* It's publicly an integer, or privately an integer-not-float */ #ifdef PERL_PRESERVE_IVUV oops_its_int: #endif - if (SvIsUV(sv)) { - if (SvUVX(sv) == 0) { - (void)SvIOK_only(sv); - SvIV_set(sv, -1); - } - else { - (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) - 1); - } - } else { - if (SvIVX(sv) == IV_MIN) { - sv_setnv(sv, (NV)IV_MIN); - goto oops_its_num; - } - else { - (void)SvIOK_only(sv); - SvIV_set(sv, SvIVX(sv) - 1); - } - } - return; + if (SvIsUV(sv)) { + if (SvUVX(sv) == 0) { + (void)SvIOK_only(sv); + SvIV_set(sv, -1); + } + else { + (void)SvIOK_only_UV(sv); + SvUV_set(sv, SvUVX(sv) - 1); + } + } else { + if (SvIVX(sv) == IV_MIN) { + sv_setnv(sv, (NV)IV_MIN); + goto oops_its_num; + } + else { + (void)SvIOK_only(sv); + SvIV_set(sv, SvIVX(sv) - 1); + } + } + return; } if (flags & SVp_NOK) { oops_its_num: - { - const NV was = SvNVX(sv); + { + const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT != 0.0 && /* If NVX was NaN, these comparisons return always false */ UNLIKELY(was <= -NV_OVERFLOWS_INTEGERS_AT || @@ -9145,15 +9145,15 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) LIKELY(!Perl_isinf(was)) #endif ) { - /* diag_listed_as: Lost precision when %s %f by 1 */ - Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when decrementing %" NVff " by 1", - was); - } - (void)SvNOK_only(sv); - SvNV_set(sv, was - 1.0); - return; - } + /* diag_listed_as: Lost precision when %s %f by 1 */ + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); + SvNV_set(sv, was - 1.0); + return; + } } /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */ @@ -9161,39 +9161,39 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) Perl_croak_no_modify(); if (!(flags & SVp_POK)) { - if ((flags & SVTYPEMASK) < SVt_PVIV) - sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); - SvIV_set(sv, -1); - (void)SvIOK_only(sv); - return; + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); + SvIV_set(sv, -1); + (void)SvIOK_only(sv); + return; } #ifdef PERL_PRESERVE_IVUV { - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); - if (numtype && !(numtype & IS_NUMBER_INFINITY)) { - /* Need to try really hard to see if it's an integer. - 9.22337203685478e+18 is an integer. - but "9.22337203685478e+18" + 0 is UV=9223372036854779904 - so $a="9.22337203685478e+18"; $a+0; $a-- - needs to be the same as $a="9.22337203685478e+18"; $a-- - or we go insane. */ - - (void) sv_2iv(sv); - if (SvIOK(sv)) - goto oops_its_int; - - /* sv_2iv *should* have made this an NV */ - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a-- + needs to be the same as $a="9.22337203685478e+18"; $a-- + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); SvNV_set(sv, SvNVX(sv) - 1.0); - return; - } - /* I don't think we can get here. Maybe I should assert this - And if we do get here I suspect that sv_setnv will croak. NWC - Fall through. */ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); - } + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); + } } #endif /* PERL_PRESERVE_IVUV */ sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ @@ -9205,10 +9205,10 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) */ #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ STMT_START { \ - SSize_t ix = ++PL_tmps_ix; \ - if (UNLIKELY(ix >= PL_tmps_max)) \ - ix = tmps_grow_p(ix); \ - PL_tmps_stack[ix] = (AnSv); \ + SSize_t ix = ++PL_tmps_ix; \ + if (UNLIKELY(ix >= PL_tmps_max)) \ + ix = tmps_grow_p(ix); \ + PL_tmps_stack[ix] = (AnSv); \ } STMT_END /* @@ -9238,7 +9238,7 @@ Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) SV *sv; if (flags & SV_GMAGIC) - SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ + SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ new_SV(sv); sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); PUSH_EXTEND_MORTAL__SV_C(sv); @@ -9285,7 +9285,7 @@ C flag will be set on the new SV. C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ - newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) =for apidoc Amnh||SVs_TEMP @@ -9314,7 +9314,7 @@ Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags SvFLAGS(sv) |= flags; if(flags & SVs_TEMP){ - PUSH_EXTEND_MORTAL__SV_C(sv); + PUSH_EXTEND_MORTAL__SV_C(sv); } return sv; @@ -9336,9 +9336,9 @@ SV * Perl_sv_2mortal(pTHX_ SV *const sv) { if (!sv) - return sv; + return sv; if (SvIMMORTAL(sv)) - return sv; + return sv; PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); return sv; @@ -9411,54 +9411,54 @@ SV * Perl_newSVhek(pTHX_ const HEK *const hek) { if (!hek) { - SV *sv; + SV *sv; - new_SV(sv); - return sv; + new_SV(sv); + return sv; } if (HEK_LEN(hek) == HEf_SVKEY) { - return newSVsv(*(SV**)HEK_KEY(hek)); + return newSVsv(*(SV**)HEK_KEY(hek)); } else { - const int flags = HEK_FLAGS(hek); - if (flags & HVhek_WASUTF8) { - /* Trouble :-) - Andreas would like keys he put in as utf8 to come back as utf8 - */ - STRLEN utf8_len = HEK_LEN(hek); - SV * const sv = newSV_type(SVt_PV); - char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - /* bytes_to_utf8() allocates a new string, which we can repurpose: */ - sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); - SvUTF8_on (sv); - return sv; + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + /* Trouble :-) + Andreas would like keys he put in as utf8 to come back as utf8 + */ + STRLEN utf8_len = HEK_LEN(hek); + SV * const sv = newSV_type(SVt_PV); + char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + /* bytes_to_utf8() allocates a new string, which we can repurpose: */ + sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); + SvUTF8_on (sv); + return sv; } else if (flags & HVhek_UNSHARED) { /* A hash that isn't using shared hash keys has to have - the flag in every key so that we know not to try to call - share_hek_hek on it. */ - - SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); - if (HEK_UTF8(hek)) - SvUTF8_on (sv); - return sv; - } - /* This will be overwhelminly the most common case. */ - { - /* Inline most of newSVpvn_share(), because share_hek_hek() is far - more efficient than sharepvn(). */ - SV *sv; - - new_SV(sv); - sv_upgrade(sv, SVt_PV); - SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); - SvCUR_set(sv, HEK_LEN(hek)); - SvLEN_set(sv, 0); - SvIsCOW_on(sv); - SvPOK_on(sv); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - return sv; - } + the flag in every key so that we know not to try to call + share_hek_hek on it. */ + + SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on (sv); + return sv; + } + /* This will be overwhelminly the most common case. */ + { + /* Inline most of newSVpvn_share(), because share_hek_hek() is far + more efficient than sharepvn(). */ + SV *sv; + + new_SV(sv); + sv_upgrade(sv, SVt_PV); + SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); + SvLEN_set(sv, 0); + SvIsCOW_on(sv); + SvPOK_on(sv); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + return sv; + } } } @@ -9486,14 +9486,14 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) const char *const orig_src = src; if (len < 0) { - STRLEN tmplen = -len; + STRLEN tmplen = -len; is_utf8 = TRUE; - /* See the note in hv.c:hv_fetch() --jhi */ - src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); - len = tmplen; + /* See the note in hv.c:hv_fetch() --jhi */ + src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); + len = tmplen; } if (!hash) - PERL_HASH(hash, src, len); + PERL_HASH(hash, src, len); new_SV(sv); /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it changes here, update it there too. */ @@ -9506,7 +9506,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (is_utf8) SvUTF8_on(sv); if (src != orig_src) - Safefree(src); + Safefree(src); return sv; } @@ -9665,7 +9665,7 @@ Perl_newSVuv(pTHX_ const UV u) /* Using ivs is more efficient than using uvs - see sv_setuv */ if (u <= (UV)IV_MAX) { - return newSViv((IV)u); + return newSViv((IV)u); } new_SV(sv); @@ -9703,7 +9703,7 @@ Perl_newSV_type(pTHX_ const svtype type) new_SV(sv); ASSUME(SvTYPE(sv) == SVt_FIRST); if(type != SVt_FIRST) - sv_upgrade(sv, type); + sv_upgrade(sv, type); return sv; } @@ -9774,10 +9774,10 @@ Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags) SV *sv; if (!old) - return NULL; + return NULL; if (SvTYPE(old) == (svtype)SVTYPEMASK) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); - return NULL; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); + return NULL; } /* Do this here, otherwise we leak the new SV if this croaks. */ if (flags & SV_GMAGIC) @@ -9811,71 +9811,71 @@ Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) const char *send; if (!stash || SvTYPE(stash) != SVt_PVHV) - return; + return; if (!s) { /* reset ?? searches */ - MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); - if (mg) { - const U32 count = mg->mg_len / sizeof(PMOP**); - PMOP **pmp = (PMOP**) mg->mg_ptr; - PMOP *const *const end = pmp + count; + MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); + if (mg) { + const U32 count = mg->mg_len / sizeof(PMOP**); + PMOP **pmp = (PMOP**) mg->mg_ptr; + PMOP *const *const end = pmp + count; - while (pmp < end) { + while (pmp < end) { #ifdef USE_ITHREADS SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); #else - (*pmp)->op_pmflags &= ~PMf_USED; + (*pmp)->op_pmflags &= ~PMf_USED; #endif - ++pmp; - } - } - return; + ++pmp; + } + } + return; } /* reset variables */ if (!HvARRAY(stash)) - return; + return; Zero(todo, 256, char); send = s + len; while (s < send) { - I32 max; - I32 i = (unsigned char)*s; - if (s[1] == '-') { - s += 2; - } - max = (unsigned char)*s++; - for ( ; i <= max; i++) { - todo[i] = 1; - } - for (i = 0; i <= (I32) HvMAX(stash); i++) { - HE *entry; - for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) - { - GV *gv; - SV *sv; - - if (!todo[(U8)*HeKEY(entry)]) - continue; - gv = MUTABLE_GV(HeVAL(entry)); - if (!isGV(gv)) - continue; - sv = GvSV(gv); - if (sv && !SvREADONLY(sv)) { - SV_CHECK_THINKFIRST_COW_DROP(sv); - if (!isGV(sv)) SvOK_off(sv); - } - if (GvAV(gv)) { - av_clear(GvAV(gv)); - } - if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { - hv_clear(GvHV(gv)); - } - } - } + I32 max; + I32 i = (unsigned char)*s; + if (s[1] == '-') { + s += 2; + } + max = (unsigned char)*s++; + for ( ; i <= max; i++) { + todo[i] = 1; + } + for (i = 0; i <= (I32) HvMAX(stash); i++) { + HE *entry; + for (entry = HvARRAY(stash)[i]; + entry; + entry = HeNEXT(entry)) + { + GV *gv; + SV *sv; + + if (!todo[(U8)*HeKEY(entry)]) + continue; + gv = MUTABLE_GV(HeVAL(entry)); + if (!isGV(gv)) + continue; + sv = GvSV(gv); + if (sv && !SvREADONLY(sv)) { + SV_CHECK_THINKFIRST_COW_DROP(sv); + if (!isGV(sv)) SvOK_off(sv); + } + if (GvAV(gv)) { + av_clear(GvAV(gv)); + } + if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { + hv_clear(GvHV(gv)); + } + } + } } } @@ -9902,40 +9902,40 @@ Perl_sv_2io(pTHX_ SV *const sv) switch (SvTYPE(sv)) { case SVt_PVIO: - io = MUTABLE_IO(sv); - break; + io = MUTABLE_IO(sv); + break; case SVt_PVGV: case SVt_PVLV: - if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %" HEKf, + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %" HEKf, HEKfARG(GvNAME_HEK(gv))); - break; - } - /* FALLTHROUGH */ + break; + } + /* FALLTHROUGH */ default: - if (!SvOK(sv)) - Perl_croak(aTHX_ PL_no_usym, "filehandle"); - if (SvROK(sv)) { - SvGETMAGIC(SvRV(sv)); - return sv_2io(SvRV(sv)); - } - gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); - if (gv) - io = GvIO(gv); - else - io = 0; - if (!io) { - SV *newsv = sv; - if (SvGMAGICAL(sv)) { - newsv = sv_newmortal(); - sv_setsv_nomg(newsv, sv); - } - Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv)); - } - break; + if (!SvOK(sv)) + Perl_croak(aTHX_ PL_no_usym, "filehandle"); + if (SvROK(sv)) { + SvGETMAGIC(SvRV(sv)); + return sv_2io(SvRV(sv)); + } + gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); + if (gv) + io = GvIO(gv); + else + io = 0; + if (!io) { + SV *newsv = sv; + if (SvGMAGICAL(sv)) { + newsv = sv_newmortal(); + sv_setsv_nomg(newsv, sv); + } + Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv)); + } + break; } return io; } @@ -9959,62 +9959,62 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) PERL_ARGS_ASSERT_SV_2CV; if (!sv) { - *st = NULL; - *gvp = NULL; - return NULL; + *st = NULL; + *gvp = NULL; + return NULL; } switch (SvTYPE(sv)) { case SVt_PVCV: - *st = CvSTASH(sv); - *gvp = NULL; - return MUTABLE_CV(sv); + *st = CvSTASH(sv); + *gvp = NULL; + return MUTABLE_CV(sv); case SVt_PVHV: case SVt_PVAV: - *st = NULL; - *gvp = NULL; - return NULL; + *st = NULL; + *gvp = NULL; + return NULL; default: - SvGETMAGIC(sv); - if (SvROK(sv)) { - if (SvAMAGIC(sv)) - sv = amagic_deref_call(sv, to_cv_amg); - - sv = SvRV(sv); - if (SvTYPE(sv) == SVt_PVCV) { - cv = MUTABLE_CV(sv); - *gvp = NULL; - *st = CvSTASH(cv); - return cv; - } - else if(SvGETMAGIC(sv), isGV_with_GP(sv)) - gv = MUTABLE_GV(sv); - else - Perl_croak(aTHX_ "Not a subroutine reference"); - } - else if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - } - else { - gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); - } - *gvp = gv; - if (!gv) { - *st = NULL; - return NULL; - } - /* Some flags to gv_fetchsv mean don't really create the GV */ - if (!isGV_with_GP(gv)) { - *st = NULL; - return NULL; - } - *st = GvESTASH(gv); - if (lref & ~GV_ADDMG && !GvCVu(gv)) { - /* XXX this is probably not what they think they're getting. - * It has the same effect as "sub name;", i.e. just a forward - * declaration! */ - newSTUB(gv,0); - } - return GvCVu(gv); + SvGETMAGIC(sv); + if (SvROK(sv)) { + if (SvAMAGIC(sv)) + sv = amagic_deref_call(sv, to_cv_amg); + + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVCV) { + cv = MUTABLE_CV(sv); + *gvp = NULL; + *st = CvSTASH(cv); + return cv; + } + else if(SvGETMAGIC(sv), isGV_with_GP(sv)) + gv = MUTABLE_GV(sv); + else + Perl_croak(aTHX_ "Not a subroutine reference"); + } + else if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + } + else { + gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); + } + *gvp = gv; + if (!gv) { + *st = NULL; + return NULL; + } + /* Some flags to gv_fetchsv mean don't really create the GV */ + if (!isGV_with_GP(gv)) { + *st = NULL; + return NULL; + } + *st = GvESTASH(gv); + if (lref & ~GV_ADDMG && !GvCVu(gv)) { + /* XXX this is probably not what they think they're getting. + * It has the same effect as "sub name;", i.e. just a forward + * declaration! */ + newSTUB(gv,0); + } + return GvCVu(gv); } } @@ -10032,25 +10032,25 @@ I32 Perl_sv_true(pTHX_ SV *const sv) { if (!sv) - return 0; + return 0; if (SvPOK(sv)) { - const XPV* const tXpv = (XPV*)SvANY(sv); - if (tXpv && - (tXpv->xpv_cur > 1 || - (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) - return 1; - else - return 0; + const XPV* const tXpv = (XPV*)SvANY(sv); + if (tXpv && + (tXpv->xpv_cur > 1 || + (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) + return 1; + else + return 0; } else { - if (SvIOK(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOK(sv)) - return SvNVX(sv) != 0.0; - else - return sv_2bool(sv); - } + if (SvIOK(sv)) + return SvIVX(sv) != 0; + else { + if (SvNOK(sv)) + return SvNVX(sv) != 0.0; + else + return sv_2bool(sv); + } } } @@ -10083,41 +10083,41 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) sv_force_normal_flags(sv, 0); if (SvPOK(sv)) { - if (lp) - *lp = SvCUR(sv); + if (lp) + *lp = SvCUR(sv); } else { - char *s; - STRLEN len; - - 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), - OP_DESC(PL_op)); - s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); - if (!s) { - s = (char *)""; - } - if (lp) - *lp = len; + char *s; + STRLEN len; + + 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), + OP_DESC(PL_op)); + s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); + if (!s) { + s = (char *)""; + } + if (lp) + *lp = len; if (SvTYPE(sv) < SVt_PV || s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ - if (SvROK(sv)) - sv_unref(sv); - SvUPGRADE(sv, SVt_PV); /* Never FALSE */ - SvGROW(sv, len + 1); - Move(s,SvPVX(sv),len,char); - SvCUR_set(sv, len); - SvPVX(sv)[len] = '\0'; - } - if (!SvPOK(sv)) { - SvPOK_on(sv); /* validate pointer */ - SvTAINT(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", - PTR2UV(sv),SvPVX_const(sv))); - } + if (SvROK(sv)) + sv_unref(sv); + SvUPGRADE(sv, SVt_PV); /* Never FALSE */ + SvGROW(sv, len + 1); + Move(s,SvPVX(sv),len,char); + SvCUR_set(sv, len); + SvPVX(sv)[len] = '\0'; + } + if (!SvPOK(sv)) { + SvPOK_on(sv); /* validate pointer */ + SvTAINT(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", + PTR2UV(sv),SvPVX_const(sv))); + } } (void)SvPOK_only_UTF8(sv); return SvPVX_mutable(sv); @@ -10179,7 +10179,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) { PERL_ARGS_ASSERT_SV_REFTYPE; if (ob && SvOBJECT(sv)) { - return SvPV_nolen_const(sv_ref(NULL, sv, ob)); + return SvPV_nolen_const(sv_ref(NULL, sv, ob)); } else { /* WARNING - There is code, for instance in mg.c, that assumes that @@ -10190,37 +10190,37 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) * Do not change this assumption without searching for "dodgy type check" in * the code. * - Yves */ - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVMG: - if (SvVOK(sv)) - return "VSTRING"; - if (SvROK(sv)) - return "REF"; - else - return "SCALAR"; - - case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" - /* tied lvalues should appear to be - * scalars for backwards compatibility */ - : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) - ? "SCALAR" : "LVALUE"); - case SVt_PVAV: return "ARRAY"; - case SVt_PVHV: return "HASH"; - case SVt_PVCV: return "CODE"; - case SVt_PVGV: return (char *) (isGV_with_GP(sv) - ? "GLOB" : "SCALAR"); - case SVt_PVFM: return "FORMAT"; - case SVt_PVIO: return "IO"; - case SVt_INVLIST: return "INVLIST"; - case SVt_REGEXP: return "REGEXP"; - default: return "UNKNOWN"; - } + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVMG: + if (SvVOK(sv)) + return "VSTRING"; + if (SvROK(sv)) + return "REF"; + else + return "SCALAR"; + + case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" + /* tied lvalues should appear to be + * scalars for backwards compatibility */ + : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) + ? "SCALAR" : "LVALUE"); + case SVt_PVAV: return "ARRAY"; + case SVt_PVHV: return "HASH"; + case SVt_PVCV: return "CODE"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); + case SVt_PVFM: return "FORMAT"; + case SVt_PVIO: return "IO"; + case SVt_INVLIST: return "INVLIST"; + case SVt_REGEXP: return "REGEXP"; + default: return "UNKNOWN"; + } } } @@ -10247,7 +10247,7 @@ Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob) dst = sv_newmortal(); if (ob && SvOBJECT(sv)) { - HvNAME_get(SvSTASH(sv)) + HvNAME_get(SvSTASH(sv)) ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))) : sv_setpvs(dst, "__ANON__"); } @@ -10272,13 +10272,13 @@ int Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) - return 0; + return 0; SvGETMAGIC(sv); if (!SvROK(sv)) - return 0; + return 0; sv = SvRV(sv); if (!SvOBJECT(sv)) - return 0; + return 0; return 1; } @@ -10304,16 +10304,16 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name) PERL_ARGS_ASSERT_SV_ISA; if (!sv) - return 0; + return 0; SvGETMAGIC(sv); if (!SvROK(sv)) - return 0; + return 0; sv = SvRV(sv); if (!SvOBJECT(sv)) - return 0; + return 0; hvname = HvNAME_get(SvSTASH(sv)); if (!hvname) - return 0; + return 0; return strEQ(hvname, name); } @@ -10342,17 +10342,17 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) SV_CHECK_THINKFIRST_COW_DROP(rv); if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) { - const U32 refcnt = SvREFCNT(rv); - SvREFCNT(rv) = 0; - sv_clear(rv); - SvFLAGS(rv) = 0; - SvREFCNT(rv) = refcnt; + const U32 refcnt = SvREFCNT(rv); + SvREFCNT(rv) = 0; + sv_clear(rv); + SvFLAGS(rv) = 0; + SvREFCNT(rv) = refcnt; - sv_upgrade(rv, SVt_IV); + sv_upgrade(rv, SVt_IV); } else if (SvROK(rv)) { - SvREFCNT_dec(SvRV(rv)); + SvREFCNT_dec(SvRV(rv)); } else { - prepare_SV_for_RV(rv); + prepare_SV_for_RV(rv); } SvOK_off(rv); @@ -10360,8 +10360,8 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) SvROK_on(rv); if (classname) { - HV* const stash = gv_stashpv(classname, GV_ADD); - (void)sv_bless(rv, stash); + HV* const stash = gv_stashpv(classname, GV_ADD); + (void)sv_bless(rv, stash); } return sv; } @@ -10403,11 +10403,11 @@ Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const p PERL_ARGS_ASSERT_SV_SETREF_PV; if (!pv) { - sv_set_undef(rv); - SvSETMAGIC(rv); + sv_set_undef(rv); + SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); + sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); return rv; } @@ -10522,11 +10522,11 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) { - if (SvREADONLY(tmpRef)) - Perl_croak_no_modify(); - if (SvOBJECT(tmpRef)) { - oldstash = SvSTASH(tmpRef); - } + if (SvREADONLY(tmpRef)) + Perl_croak_no_modify(); + if (SvOBJECT(tmpRef)) { + oldstash = SvSTASH(tmpRef); + } } SvOBJECT_on(tmpRef); SvUPGRADE(tmpRef, SVt_PVMG); @@ -10558,34 +10558,34 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); SvFAKE_off(sv); if (!(flags & SV_COW_DROP_PV)) - gv_efullname3(temp, MUTABLE_GV(sv), "*"); + gv_efullname3(temp, MUTABLE_GV(sv), "*"); SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); if (GvGP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) - && HvNAME_get(stash)) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free(MUTABLE_GV(sv)); + gp_free(MUTABLE_GV(sv)); } if (GvSTASH(sv)) { - sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); - GvSTASH(sv) = NULL; + sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); + GvSTASH(sv) = NULL; } GvMULTI_off(sv); if (GvNAME_HEK(sv)) { - unshare_hek(GvNAME_HEK(sv)); + unshare_hek(GvNAME_HEK(sv)); } isGV_with_GP_off(sv); if(SvTYPE(sv) == SVt_PVGV) { - /* need to keep SvANY(sv) in the right arena */ - xpvmg = new_XPVMG(); - StructCopy(SvANY(sv), xpvmg, XPVMG); - del_XPVGV(SvANY(sv)); - SvANY(sv) = xpvmg; + /* need to keep SvANY(sv) in the right arena */ + xpvmg = new_XPVMG(); + StructCopy(SvANY(sv), xpvmg, XPVMG); + del_XPVGV(SvANY(sv)); + SvANY(sv) = xpvmg; - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= SVt_PVMG; + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= SVt_PVMG; } /* Intentionally not calling any local SET magic, as this isn't so much a @@ -10594,9 +10594,9 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) else sv_setsv_flags(sv, temp, 0); if ((const GV *)sv == PL_last_in_gv) - PL_last_in_gv = NULL; + PL_last_in_gv = NULL; else if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; + PL_statgv = NULL; } /* @@ -10623,19 +10623,19 @@ Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) PERL_ARGS_ASSERT_SV_UNREF_FLAGS; if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - return; + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + return; } SvRV_set(ref, NULL); SvROK_off(ref); /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was assigned to as BEGIN {$a = \"Foo"} will fail. */ if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) - SvREFCNT_dec_NN(target); + SvREFCNT_dec_NN(target); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ - sv_2mortal(target); /* Schedule for freeing later */ + sv_2mortal(target); /* Schedule for freeing later */ } /* @@ -10653,9 +10653,9 @@ Perl_sv_untaint(pTHX_ SV *const sv) PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); - if (mg) - mg->mg_len &= ~1; + MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + if (mg) + mg->mg_len &= ~1; } } @@ -10674,9 +10674,9 @@ Perl_sv_tainted(pTHX_ SV *const sv) PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); - if (mg && (mg->mg_len & 1) ) - return TRUE; + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + if (mg && (mg->mg_len & 1) ) + return TRUE; } return FALSE; } @@ -11027,8 +11027,8 @@ S_sv_catpvn_simple(pTHX_ SV *const sv, const char* const buf, const STRLEN len) STATIC void S_warn_vcatpvfn_missing_argument(pTHX) { if (ckWARN(WARN_MISSING)) { - Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } } @@ -11133,24 +11133,24 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) assert(!Perl_isinfnan(nv)); if (neg) - nv = -nv; + nv = -nv; if (nv != 0.0 && nv < (NV) UV_MAX) { - char *p = endbuf; - uv = (UV)nv; - if (uv != nv) { - nv += 0.5; - uv = (UV)nv; - if (uv & 1 && uv == nv) - uv--; /* Round to even */ - } - do { - const unsigned dig = uv % 10; - *--p = '0' + dig; - } while (uv /= 10); - if (neg) - *--p = '-'; - *len = endbuf - p; - return p; + char *p = endbuf; + uv = (UV)nv; + if (uv != nv) { + nv += 0.5; + uv = (UV)nv; + if (uv & 1 && uv == nv) + uv--; /* Round to even */ + } + do { + const unsigned dig = uv % 10; + *--p = '0' + dig; + } while (uv /= 10); + if (neg) + *--p = '-'; + *len = endbuf - p; + return p; } return NULL; } @@ -11176,7 +11176,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * synonym for "double"). */ #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ - defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) + defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) # define VCATPVFN_FV_GF PERL_PRIgldbl # if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT) /* Work around breakage in OTS$CVT_FLOAT_T_X */ @@ -11345,7 +11345,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, /* The bytes 13..0 are the mantissa/fraction, * the 15,14 are the sign+exponent. */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); # undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_LE(13, 0); @@ -11355,7 +11355,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, /* The bytes 2..15 are the mantissa/fraction, * the 0,1 are the sign+exponent. */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); # undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_BE(2, 15); @@ -11365,11 +11365,11 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux * and OS X), meaning that 2 or 6 bytes are empty padding. */ /* The bytes 0..1 are the sign+exponent, - * the bytes 2..9 are the mantissa/fraction. */ + * the bytes 2..9 are the mantissa/fraction. */ const U8* nvp = (const U8*)(&nv); # undef HEXTRACT_HAS_IMPLICIT_BIT # undef HEXTRACT_HAS_TOP_NYBBLE - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_BYTES_LE(7, 0); # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN /* Does this format ever happen? (Wikipedia says the Motorola @@ -11379,7 +11379,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, const U8* nvp = (const U8*)(&nv); # undef HEXTRACT_HAS_IMPLICIT_BIT # undef HEXTRACT_HAS_TOP_NYBBLE - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_BYTES_BE(0, 7); # else # define HEXTRACT_FALLBACK @@ -11415,21 +11415,21 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, # ifdef HEXTRACT_LITTLE_ENDIAN /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(6); HEXTRACT_BYTES_LE(5, 0); # elif defined(HEXTRACT_BIG_ENDIAN) /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(1); HEXTRACT_BYTES_BE(2, 7); # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(2); /* 6 */ HEXTRACT_BYTE(1); /* 5 */ @@ -11441,7 +11441,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(5); /* 6 */ HEXTRACT_BYTE(6); /* 5 */ @@ -11459,7 +11459,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */ #ifdef HEXTRACT_FALLBACK - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); # undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */ /* The fallback is used for the double-double format, and * for unknown long double formats, and for unknown double @@ -11936,7 +11936,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p */ if (patlen == 0 && (args || sv_count == 0)) - return; + return; if (patlen <= 4 && pat[0] == '%' && (args || sv_count == 1)) { @@ -11985,46 +11985,46 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p patend = (char*)pat + patlen; for (fmtstart = pat; fmtstart < patend; fmtstart = q) { - char intsize = 0; /* size qualifier in "%hi..." etc */ - bool alt = FALSE; /* has "%#..." */ - bool left = FALSE; /* has "%-..." */ - bool fill = FALSE; /* has "%0..." */ - char plus = 0; /* has "%+..." */ - STRLEN width = 0; /* value of "%NNN..." */ - bool has_precis = FALSE; /* has "%.NNN..." */ - STRLEN precis = 0; /* value of "%.NNN..." */ - int base = 0; /* base to print in, e.g. 8 for %o */ - UV uv = 0; /* the value to print of int-ish args */ - - bool vectorize = FALSE; /* has "%v..." */ - bool vec_utf8 = FALSE; /* SvUTF8(vec arg) */ - const U8 *vecstr = NULL; /* SvPVX(vec arg) */ - STRLEN veclen = 0; /* SvCUR(vec arg) */ - const char *dotstr = NULL; /* separator string for %v */ - STRLEN dotstrlen; /* length of separator string for %v */ - - Size_t efix = 0; /* explicit format parameter index */ - const Size_t osvix = svix; /* original index in case of bad fmt */ - - SV *argsv = NULL; - bool is_utf8 = FALSE; /* is this item utf8? */ + char intsize = 0; /* size qualifier in "%hi..." etc */ + bool alt = FALSE; /* has "%#..." */ + bool left = FALSE; /* has "%-..." */ + bool fill = FALSE; /* has "%0..." */ + char plus = 0; /* has "%+..." */ + STRLEN width = 0; /* value of "%NNN..." */ + bool has_precis = FALSE; /* has "%.NNN..." */ + STRLEN precis = 0; /* value of "%.NNN..." */ + int base = 0; /* base to print in, e.g. 8 for %o */ + UV uv = 0; /* the value to print of int-ish args */ + + bool vectorize = FALSE; /* has "%v..." */ + bool vec_utf8 = FALSE; /* SvUTF8(vec arg) */ + const U8 *vecstr = NULL; /* SvPVX(vec arg) */ + STRLEN veclen = 0; /* SvCUR(vec arg) */ + const char *dotstr = NULL; /* separator string for %v */ + STRLEN dotstrlen; /* length of separator string for %v */ + + Size_t efix = 0; /* explicit format parameter index */ + const Size_t osvix = svix; /* original index in case of bad fmt */ + + SV *argsv = NULL; + bool is_utf8 = FALSE; /* is this item utf8? */ bool arg_missing = FALSE; /* give "Missing argument" warning */ - char esignbuf[4]; /* holds sign prefix, e.g. "-0x" */ - STRLEN esignlen = 0; /* length of e.g. "-0x" */ - STRLEN zeros = 0; /* how many '0' to prepend */ + char esignbuf[4]; /* holds sign prefix, e.g. "-0x" */ + STRLEN esignlen = 0; /* length of e.g. "-0x" */ + STRLEN zeros = 0; /* how many '0' to prepend */ - const char *eptr = NULL; /* the address of the element string */ - STRLEN elen = 0; /* the length of the element string */ + const char *eptr = NULL; /* the address of the element string */ + STRLEN elen = 0; /* the length of the element string */ - char c; /* the actual format ('d', s' etc) */ + char c; /* the actual format ('d', s' etc) */ - /* echo everything up to the next format specification */ - for (q = fmtstart; q < patend && *q != '%'; ++q) + /* echo everything up to the next format specification */ + for (q = fmtstart; q < patend && *q != '%'; ++q) {}; - if (q > fmtstart) { - if (has_utf8 && !pat_utf8) { + if (q > fmtstart) { + if (has_utf8 && !pat_utf8) { /* upgrade and copy the bytes of fmtstart..q-1 to utf8 on * the fly */ const char *p; @@ -12042,73 +12042,73 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p *dst = '\0'; SvCUR_set(sv, need - 1); } - else + else S_sv_catpvn_simple(aTHX_ sv, fmtstart, q - fmtstart); - } - if (q++ >= patend) - break; + } + if (q++ >= patend) + break; - fmtstart = q; /* fmtstart is char following the '%' */ + fmtstart = q; /* fmtstart is char following the '%' */ /* We allow format specification elements in this order: - \d+\$ explicit format parameter index - [-+ 0#]+ flags - v|\*(\d+\$)?v vector with optional (optionally specified) arg - 0 flag (as above): repeated to allow "v02" - \d+|\*(\d+\$)? width using optional (optionally specified) arg - \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg - [hlqLV] size + \d+\$ explicit format parameter index + [-+ 0#]+ flags + v|\*(\d+\$)?v vector with optional (optionally specified) arg + 0 flag (as above): repeated to allow "v02" + \d+|\*(\d+\$)? width using optional (optionally specified) arg + \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg + [hlqLV] size [%bcdefginopsuxDFOUX] format (mandatory) */ - if (inRANGE(*q, '1', '9')) { + if (inRANGE(*q, '1', '9')) { width = expect_number(&q); - if (*q == '$') { + if (*q == '$') { if (args) Perl_croak_nocontext( "Cannot yet reorder sv_vcatpvfn() arguments from va_list"); - ++q; - efix = (Size_t)width; + ++q; + efix = (Size_t)width; width = 0; no_redundant_warning = TRUE; - } else { - goto gotwidth; - } - } - - /* FLAGS */ - - while (*q) { - switch (*q) { - case ' ': - case '+': - if (plus == '+' && *q == ' ') /* '+' over ' ' */ - q++; - else - plus = *q++; - continue; - - case '-': - left = TRUE; - q++; - continue; - - case '0': - fill = TRUE; + } else { + goto gotwidth; + } + } + + /* FLAGS */ + + while (*q) { + switch (*q) { + case ' ': + case '+': + if (plus == '+' && *q == ' ') /* '+' over ' ' */ + q++; + else + plus = *q++; + continue; + + case '-': + left = TRUE; + q++; + continue; + + case '0': + fill = TRUE; q++; - continue; + continue; - case '#': - alt = TRUE; - q++; - continue; + case '#': + alt = TRUE; + q++; + continue; - default: - break; - } - break; - } + default: + break; + } + break; + } /* at this point we can expect one of: * @@ -12127,18 +12127,18 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p */ tryasterisk: - if (*q == '*') { + if (*q == '*') { STRLEN ix; /* explicit width/vector separator index */ - q++; + q++; if (inRANGE(*q, '1', '9')) { ix = expect_number(&q); - if (*q++ == '$') { + if (*q++ == '$') { if (args) Perl_croak_nocontext( "Cannot yet reorder sv_vcatpvfn() arguments from va_list"); no_redundant_warning = TRUE; } else - goto unknown; + goto unknown; } else ix = 0; @@ -12186,35 +12186,35 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left); } } - else if (*q == 'v') { - q++; - if (vectorize) - goto unknown; - vectorize = TRUE; + else if (*q == 'v') { + q++; + if (vectorize) + goto unknown; + vectorize = TRUE; dotstr = "."; dotstrlen = 1; goto tryasterisk; } - else { + else { /* explicit width? */ - if(*q == '0') { - fill = TRUE; + if(*q == '0') { + fill = TRUE; q++; } if (inRANGE(*q, '1', '9')) width = expect_number(&q); - } + } gotwidth: - /* PRECISION */ + /* PRECISION */ - if (*q == '.') { - q++; - if (*q == '*') { + if (*q == '.') { + q++; + if (*q == '*') { STRLEN ix; /* explicit precision index */ - q++; + q++; if (inRANGE(*q, '1', '9')) { ix = expect_number(&q); if (*q++ == '$') { @@ -12246,8 +12246,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (!has_precis) precis = 0; } - } - else { + } + else { /* although it doesn't seem documented, this code has long * behaved so that: * no digits following the '.' is treated like '.0' @@ -12258,88 +12258,88 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p while (*q == '0') q++; precis = inRANGE(*q, '1', '9') ? expect_number(&q) : 0; - has_precis = TRUE; - } - } + has_precis = TRUE; + } + } - /* SIZE */ + /* SIZE */ - switch (*q) { + switch (*q) { #ifdef WIN32 - case 'I': /* Ix, I32x, and I64x */ + case 'I': /* Ix, I32x, and I64x */ # ifdef USE_64_BIT_INT - if (q[1] == '6' && q[2] == '4') { - q += 3; - intsize = 'q'; - break; - } + if (q[1] == '6' && q[2] == '4') { + q += 3; + intsize = 'q'; + break; + } # endif - if (q[1] == '3' && q[2] == '2') { - q += 3; - break; - } + if (q[1] == '3' && q[2] == '2') { + q += 3; + break; + } # ifdef USE_64_BIT_INT - intsize = 'q'; + intsize = 'q'; # endif - q++; - break; + q++; + break; #endif #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE)) - case 'L': /* Ld */ - /* FALLTHROUGH */ + case 'L': /* Ld */ + /* FALLTHROUGH */ # if IVSIZE >= 8 - case 'q': /* qd */ + case 'q': /* qd */ # endif - intsize = 'q'; - q++; - break; + intsize = 'q'; + q++; + break; #endif - case 'l': - ++q; + case 'l': + ++q; #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE)) - if (*q == 'l') { /* lld, llf */ - intsize = 'q'; - ++q; - } - else + if (*q == 'l') { /* lld, llf */ + intsize = 'q'; + ++q; + } + else #endif - intsize = 'l'; - break; - case 'h': - if (*++q == 'h') { /* hhd, hhu */ - intsize = 'c'; - ++q; - } - else - intsize = 'h'; - break; + intsize = 'l'; + break; + case 'h': + if (*++q == 'h') { /* hhd, hhu */ + intsize = 'c'; + ++q; + } + else + intsize = 'h'; + break; #ifdef USE_QUADMATH case 'Q': #endif - case 'V': - case 'z': - case 't': + case 'V': + case 'z': + case 't': case 'j': - intsize = *q++; - break; - } + intsize = *q++; + break; + } - /* CONVERSION */ + /* CONVERSION */ - c = *q++; /* c now holds the conversion type */ + c = *q++; /* c now holds the conversion type */ /* '%' doesn't have an arg, so skip arg processing */ - if (c == '%') { - eptr = q - 1; - elen = 1; - if (vectorize) - goto unknown; - goto string; - } - - if (vectorize && !memCHRs("BbDdiOouUXx", c)) + if (c == '%') { + eptr = q - 1; + elen = 1; + if (vectorize) + goto unknown; + goto string; + } + + if (vectorize && !memCHRs("BbDdiOouUXx", c)) goto unknown; /* get next arg (individual branches do their own va_arg() @@ -12349,55 +12349,55 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p efix = efix ? efix - 1 : svix++; argsv = efix < sv_count ? svargs[efix] : (arg_missing = TRUE, &PL_sv_no); - } + } - switch (c) { + switch (c) { - /* STRINGS */ + /* STRINGS */ - case 's': - if (args) { - eptr = va_arg(*args, char*); - if (eptr) + case 's': + if (args) { + eptr = va_arg(*args, char*); + if (eptr) if (has_precis) elen = my_strnlen(eptr, precis); else elen = strlen(eptr); - else { - eptr = (char *)nullstr; - elen = sizeof nullstr - 1; - } - } - else { - eptr = SvPV_const(argsv, elen); - if (DO_UTF8(argsv)) { - STRLEN old_precis = precis; - if (has_precis && precis < elen) { - STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); - STRLEN p = precis > ulen ? ulen : precis; - precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); - /* sticks at end */ - } - if (width) { /* fudge width (can't fudge elen) */ - if (has_precis && precis < elen) - width += precis - old_precis; - else - width += - elen - sv_or_pv_len_utf8(argsv,eptr,elen); - } - is_utf8 = TRUE; - } - } - - string: - if (has_precis && precis < elen) - elen = precis; - break; - - /* INTEGERS */ - - case 'p': + else { + eptr = (char *)nullstr; + elen = sizeof nullstr - 1; + } + } + else { + eptr = SvPV_const(argsv, elen); + if (DO_UTF8(argsv)) { + STRLEN old_precis = precis; + if (has_precis && precis < elen) { + STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); + STRLEN p = precis > ulen ? ulen : precis; + precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); + /* sticks at end */ + } + if (width) { /* fudge width (can't fudge elen) */ + if (has_precis && precis < elen) + width += precis - old_precis; + else + width += + elen - sv_or_pv_len_utf8(argsv,eptr,elen); + } + is_utf8 = TRUE; + } + } + + string: + if (has_precis && precis < elen) + elen = precis; + break; + + /* INTEGERS */ + + case 'p': /* %p extensions: * @@ -12470,12 +12470,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* treat as normal %...p */ - uv = PTR2UV(args ? va_arg(*args, void*) : argsv); - base = 16; + uv = PTR2UV(args ? va_arg(*args, void*) : argsv); + base = 16; c = 'x'; /* in case the format string contains '#' */ - goto do_integer; + goto do_integer; - case 'c': + case 'c': /* Ignore any size specifiers, since they're not documented as * being allowed for %c (ideally we should warn on e.g. '%hc'). * Setting a default intsize, along with a positive @@ -12491,16 +12491,16 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p base = 1; /* special value that indicates we're doing a 'c' */ goto get_int_arg_val; - case 'D': + case 'D': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif base = -10; goto get_int_arg_val; - case 'd': + case 'd': /* probably just a plain %d, but it might be the start of the * special UTF8f format, which usually looks something like * "%d%lu%4p" (the lu may vary by platform) @@ -12508,67 +12508,67 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p assert((UTF8f)[0] == 'd'); assert((UTF8f)[1] == '%'); - if ( args /* UTF8f only valid for C-ish sprintf */ + if ( args /* UTF8f only valid for C-ish sprintf */ && q == fmtstart + 1 /* plain %d, not %....d */ && patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */ && *q == '%' && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 3)) { - /* The argument has already gone through cBOOL, so the cast - is safe. */ - is_utf8 = (bool)va_arg(*args, int); - elen = va_arg(*args, UV); + /* The argument has already gone through cBOOL, so the cast + is safe. */ + is_utf8 = (bool)va_arg(*args, int); + elen = va_arg(*args, UV); /* if utf8 length is larger than 0x7ffff..., then it might * have been a signed value that wrapped */ if (elen > ((~(STRLEN)0) >> 1)) { assert(0); /* in DEBUGGING build we want to crash */ elen = 0; /* otherwise we want to treat this as an empty string */ } - eptr = va_arg(*args, char *); - q += sizeof(UTF8f) - 2; - goto string; - } + eptr = va_arg(*args, char *); + q += sizeof(UTF8f) - 2; + goto string; + } - /* FALLTHROUGH */ - case 'i': + /* FALLTHROUGH */ + case 'i': base = -10; goto get_int_arg_val; - case 'U': + case 'U': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif - /* FALLTHROUGH */ - case 'u': - base = 10; - goto get_int_arg_val; + /* FALLTHROUGH */ + case 'u': + base = 10; + goto get_int_arg_val; - case 'B': - case 'b': - base = 2; - goto get_int_arg_val; + case 'B': + case 'b': + base = 2; + goto get_int_arg_val; - case 'O': + case 'O': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif - /* FALLTHROUGH */ - case 'o': - base = 8; - goto get_int_arg_val; + /* FALLTHROUGH */ + case 'o': + base = 8; + goto get_int_arg_val; - case 'X': - case 'x': - base = 16; + case 'X': + case 'x': + base = 16; get_int_arg_val: - if (vectorize) { - STRLEN ulen; + if (vectorize) { + STRLEN ulen; SV *vecsv; if (base < 0) { @@ -12603,20 +12603,20 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* This is the re-entry point for when we're iterating * over the individual characters of a vector arg */ - vector: - if (!veclen) + vector: + if (!veclen) goto done_valid_conversion; - if (vec_utf8) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, - UTF8_ALLOW_ANYUV); - else { - uv = *vecstr; - ulen = 1; - } - vecstr += ulen; - veclen -= ulen; - } - else { + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); + else { + uv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else { /* test arg for inf/nan. This can trigger an unwanted * 'str' overload, so manually force 'num' overload first * if necessary */ @@ -12730,16 +12730,16 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - do_integer: - { - char *ptr = ebuf + sizeof ebuf; + do_integer: + { + char *ptr = ebuf + sizeof ebuf; unsigned dig; - zeros = 0; + zeros = 0; - switch (base) { - case 16: + switch (base) { + case 16: { - const char * const p = + const char * const p = (c == 'X') ? PL_hexdigit + 16 : PL_hexdigit; do { @@ -12752,26 +12752,26 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } break; } - case 8: - do { - dig = uv & 7; - *--ptr = '0' + dig; - } while (uv >>= 3); - if (alt && *ptr != '0') - *--ptr = '0'; - break; - case 2: - do { - dig = uv & 1; - *--ptr = '0' + dig; - } while (uv >>= 1); - if (alt && *ptr != '0') { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'b' or 'B' */ - } - break; - - case 1: + case 8: + do { + dig = uv & 7; + *--ptr = '0' + dig; + } while (uv >>= 3); + if (alt && *ptr != '0') + *--ptr = '0'; + break; + case 2: + do { + dig = uv & 1; + *--ptr = '0' + dig; + } while (uv >>= 1); + if (alt && *ptr != '0') { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'b' or 'B' */ + } + break; + + case 1: /* special-case: base 1 indicates a 'c' format: * we use the common code for extracting a uv, * but handle that value differently here than @@ -12792,37 +12792,37 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } goto string; - default: /* it had better be ten or less */ - do { - dig = uv % base; - *--ptr = '0' + dig; - } while (uv /= base); - break; - } - elen = (ebuf + sizeof ebuf) - ptr; - eptr = ptr; - if (has_precis) { - if (precis > elen) - zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0' - && !(base == 8 && alt)) /* "%#.0o" prints "0" */ - elen = 0; + default: /* it had better be ten or less */ + do { + dig = uv % base; + *--ptr = '0' + dig; + } while (uv /= base); + break; + } + elen = (ebuf + sizeof ebuf) - ptr; + eptr = ptr; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0' + && !(base == 8 && alt)) /* "%#.0o" prints "0" */ + elen = 0; /* a precision nullifies the 0 flag. */ fill = FALSE; - } - } - break; + } + } + break; - /* FLOATING POINT */ + /* FLOATING POINT */ - case 'F': - c = 'f'; /* maybe %F isn't supported here */ - /* FALLTHROUGH */ - case 'e': case 'E': - case 'f': - case 'g': case 'G': - case 'a': case 'A': + case 'F': + c = 'f'; /* maybe %F isn't supported here */ + /* FALLTHROUGH */ + case 'e': case 'E': + case 'f': + case 'g': case 'G': + case 'a': case 'A': { STRLEN float_need; /* what PL_efloatsize needs to become */ @@ -12831,43 +12831,43 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p vcatpvfn_long_double_t fv; NV nv; - /* This is evil, but floating point is even more evil */ + /* This is evil, but floating point is even more evil */ - /* for SV-style calling, we can only get NV - for C-style calling, we assume %f is double; - for simplicity we allow any of %Lf, %llf, %qf for long double - */ - switch (intsize) { + /* for SV-style calling, we can only get NV + for C-style calling, we assume %f is double; + for simplicity we allow any of %Lf, %llf, %qf for long double + */ + switch (intsize) { #if defined(USE_QUADMATH) case 'Q': break; #endif - case 'V': + case 'V': #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) - intsize = 'q'; + intsize = 'q'; #endif - break; + break; /* [perl #20339] - we should accept and ignore %lf rather than die */ - case 'l': - /* FALLTHROUGH */ - default: + case 'l': + /* FALLTHROUGH */ + default: #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) - intsize = args ? 0 : 'q'; + intsize = args ? 0 : 'q'; #endif - break; - case 'q': + break; + case 'q': #if defined(HAS_LONG_DOUBLE) - break; + break; #else - /* FALLTHROUGH */ + /* FALLTHROUGH */ #endif - case 'c': - case 'h': - case 'z': - case 't': - case 'j': - goto unknown; - } + case 'c': + case 'h': + case 'z': + case 't': + case 'j': + goto unknown; + } /* Now we need (long double) if intsize == 'q', else (double). */ if (args) { @@ -13016,7 +13016,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p hexfp = FALSE; - if (isALPHA_FOLD_EQ(c, 'f')) { + if (isALPHA_FOLD_EQ(c, 'f')) { /* Determine how many digits before the radix point * might be emitted. frexp() (or frexpl) has some * unspecified behaviour for nan/inf/-inf, so lucky we've @@ -13071,7 +13071,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p assert(float_need < ((STRLEN)~0) - digits); float_need += digits; } - } + } /* special-case "%.g" if it will fit in ebuf */ else if (c == 'g' && precis /* See earlier comment about buggy Gconvert @@ -13096,7 +13096,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p elen = strlen(ebuf); eptr = ebuf; goto float_concat; - } + } { @@ -13109,8 +13109,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p float_need += pr; } - if (float_need < width) - float_need = width; + if (float_need < width) + float_need = width; if (float_need > INT_MAX) { /* snprintf() returns an int, and we use that return value, @@ -13119,7 +13119,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Perl_croak(aTHX_ "Numeric format result too large"); } - if (PL_efloatsize <= float_need) { + if (PL_efloatsize <= float_need) { /* PL_efloatbuf should be at least 1 greater than * float_need to allow a trailing \0 to be returned by * snprintf(). If we need to grow, overgrow for the @@ -13128,11 +13128,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (float_need >= ((STRLEN)~0) - extra) croak_memory_wrap(); float_need += extra; - Safefree(PL_efloatbuf); - PL_efloatsize = float_need; - Newx(PL_efloatbuf, PL_efloatsize, char); - PL_efloatbuf[0] = '\0'; - } + Safefree(PL_efloatbuf); + PL_efloatsize = float_need; + Newx(PL_efloatbuf, PL_efloatsize, char); + PL_efloatbuf[0] = '\0'; + } if (UNLIKELY(hexfp)) { elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c, @@ -13152,40 +13152,40 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p *--ptr = 'Q'; /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #elif defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) - /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, - * not USE_LONG_DOUBLE and NVff. In other words, - * this needs to work without USE_LONG_DOUBLE. */ - if (intsize == 'q') { - /* Copy the one or more characters in a long double - * format before the 'base' ([efgEFG]) character to - * the format string. */ - static char const ldblf[] = PERL_PRIfldbl; - char const *p = ldblf + sizeof(ldblf) - 3; - while (p >= ldblf) { *--ptr = *p--; } - } + /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, + * not USE_LONG_DOUBLE and NVff. In other words, + * this needs to work without USE_LONG_DOUBLE. */ + if (intsize == 'q') { + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const ldblf[] = PERL_PRIfldbl; + char const *p = ldblf + sizeof(ldblf) - 3; + while (p >= ldblf) { *--ptr = *p--; } + } #endif - if (has_precis) { - base = precis; - do { *--ptr = '0' + (base % 10); } while (base /= 10); - *--ptr = '.'; - } - if (width) { - base = width; - do { *--ptr = '0' + (base % 10); } while (base /= 10); - } - if (fill) - *--ptr = '0'; - if (left) - *--ptr = '-'; - if (plus) - *--ptr = plus; - if (alt) - *--ptr = '#'; - *--ptr = '%'; - - /* No taint. Otherwise we are in the strange situation - * where printf() taints but print($float) doesn't. - * --jhi */ + if (has_precis) { + base = precis; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + *--ptr = '.'; + } + if (width) { + base = width; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + } + if (fill) + *--ptr = '0'; + if (left) + *--ptr = '-'; + if (plus) + *--ptr = plus; + if (alt) + *--ptr = '#'; + *--ptr = '%'; + + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ /* hopefully the above makes ptr a very constrained format * that is safe to use, even though it's not literal */ @@ -13214,11 +13214,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p ); #endif GCC_DIAG_RESTORE_STMT; - } + } - eptr = PL_efloatbuf; + eptr = PL_efloatbuf; - float_concat: + float_concat: /* Since floating-point formats do their own formatting and * padding, we skip the main block of code at the end of this @@ -13235,9 +13235,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto done_valid_conversion; } - /* SPECIAL */ + /* SPECIAL */ - case 'n': + case 'n': { STRLEN len; /* XXX ideally we should warn if any flags etc have been @@ -13280,65 +13280,65 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto done_valid_conversion; } - /* UNKNOWN */ + /* UNKNOWN */ + + default: + unknown: + if (!args + && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) + && ckWARN(WARN_PRINTF)) + { + SV * const msg = sv_newmortal(); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", + (PL_op->op_type == OP_PRTF) ? "" : "s"); + if (fmtstart < patend) { + const char * const fmtend = q < patend ? q : patend; + const char * f; + sv_catpvs(msg, "\"%"); + for (f = fmtstart; f < fmtend; f++) { + if (isPRINT(*f)) { + sv_catpvn_nomg(msg, f, 1); + } else { + Perl_sv_catpvf(aTHX_ msg, + "\\%03" UVof, (UV)*f & 0xFF); + } + } + sv_catpvs(msg, "\""); + } else { + sv_catpvs(msg, "end of string"); + } + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%" SVf, SVfARG(msg)); /* yes, this is reentrant */ + } - default: - unknown: - if (!args - && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) - && ckWARN(WARN_PRINTF)) - { - SV * const msg = sv_newmortal(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", - (PL_op->op_type == OP_PRTF) ? "" : "s"); - if (fmtstart < patend) { - const char * const fmtend = q < patend ? q : patend; - const char * f; - sv_catpvs(msg, "\"%"); - for (f = fmtstart; f < fmtend; f++) { - if (isPRINT(*f)) { - sv_catpvn_nomg(msg, f, 1); - } else { - Perl_sv_catpvf(aTHX_ msg, - "\\%03" UVof, (UV)*f & 0xFF); - } - } - sv_catpvs(msg, "\""); - } else { - sv_catpvs(msg, "end of string"); - } - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%" SVf, SVfARG(msg)); /* yes, this is reentrant */ - } - - /* mangled format: output the '%', then continue from the + /* mangled format: output the '%', then continue from the * character following that */ sv_catpvn_nomg(sv, fmtstart-1, 1); q = fmtstart; - svix = osvix; + svix = osvix; /* Any "redundant arg" warning from now onwards will probably * just be misleading, so don't bother. */ no_redundant_warning = TRUE; - continue; /* not "break" */ - } - - if (is_utf8 != has_utf8) { - if (is_utf8) { - if (SvCUR(sv)) - sv_utf8_upgrade(sv); - } - else { - const STRLEN old_elen = elen; - SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); - sv_utf8_upgrade(nsv); - eptr = SvPVX_const(nsv); - elen = SvCUR(nsv); - - if (width) { /* fudge width (can't fudge elen) */ - width += elen - old_elen; - } - is_utf8 = TRUE; - } - } + continue; /* not "break" */ + } + + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) + sv_utf8_upgrade(sv); + } + else { + const STRLEN old_elen = elen; + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); + sv_utf8_upgrade(nsv); + eptr = SvPVX_const(nsv); + elen = SvCUR(nsv); + + if (width) { /* fudge width (can't fudge elen) */ + width += elen - old_elen; + } + is_utf8 = TRUE; + } + } /* append esignbuf, filler, zeros, eptr and dotstr to sv */ @@ -13411,14 +13411,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p SvUTF8_on(sv); } - if (vectorize && veclen) { + if (vectorize && veclen) { /* we append the vector separator separately since %v isn't * very common: don't slow down the general case by adding * dotstrlen to need etc */ sv_catpvn_nomg(sv, dotstr, dotstrlen); esignlen = 0; goto vector; /* do next iteration */ - } + } done_valid_conversion: @@ -13430,8 +13430,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * do we have things left on the stack that we didn't use? */ if (!no_redundant_warning && sv_count >= svix + 1 && ckWARN(WARN_REDUNDANT)) { - Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { @@ -13497,12 +13497,12 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_PARSER_DUP; if (!proto) - return NULL; + return NULL; /* look for it in the table first */ parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); if (parser) - return parser; + return parser; /* create anew and remember what it is */ Newxz(parser, 1, yy_parser); @@ -13513,9 +13513,9 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->lex_brackets = proto->lex_brackets; parser->lex_casemods = proto->lex_casemods; parser->lex_brackstack = savepvn(proto->lex_brackstack, - (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); + (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); parser->lex_casestack = savepvn(proto->lex_casestack, - (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); + (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); parser->lex_defer = proto->lex_defer; parser->lex_dojoin = proto->lex_dojoin; parser->lex_formbrack = proto->lex_formbrack; @@ -13551,23 +13551,23 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->recheck_utf8_validity = proto->recheck_utf8_validity; { - char * const ols = SvPVX(proto->linestr); - char * const ls = SvPVX(parser->linestr); + char * const ols = SvPVX(proto->linestr); + char * const ls = SvPVX(parser->linestr); - parser->bufptr = ls + (proto->bufptr >= ols ? - proto->bufptr - ols : 0); - parser->oldbufptr = ls + (proto->oldbufptr >= ols ? - proto->oldbufptr - ols : 0); - parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? - proto->oldoldbufptr - ols : 0); - parser->linestart = ls + (proto->linestart >= ols ? - proto->linestart - ols : 0); - parser->last_uni = ls + (proto->last_uni >= ols ? - proto->last_uni - ols : 0); - parser->last_lop = ls + (proto->last_lop >= ols ? - proto->last_lop - ols : 0); + parser->bufptr = ls + (proto->bufptr >= ols ? + proto->bufptr - ols : 0); + parser->oldbufptr = ls + (proto->oldbufptr >= ols ? + proto->oldbufptr - ols : 0); + parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? + proto->oldoldbufptr - ols : 0); + parser->linestart = ls + (proto->linestart >= ols ? + proto->linestart - ols : 0); + parser->last_uni = ls + (proto->last_uni >= ols ? + proto->last_uni - ols : 0); + parser->last_lop = ls + (proto->last_lop >= ols ? + proto->last_lop - ols : 0); - parser->bufend = ls + SvCUR(parser->linestr); + parser->bufend = ls + SvCUR(parser->linestr); } Copy(proto->tokenbuf, parser->tokenbuf, 256, char); @@ -13595,12 +13595,12 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) PERL_UNUSED_ARG(type); if (!fp) - return (PerlIO*)NULL; + return (PerlIO*)NULL; /* look for it in the table first */ ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); if (ret) - return ret; + return ret; /* create anew and remember what it is */ #ifdef __amigaos4__ @@ -13632,12 +13632,12 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_DIRP_DUP; if (!dp) - return (DIR*)NULL; + return (DIR*)NULL; /* look for it in the table first */ ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp); if (ret) - return ret; + return ret; #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) @@ -13650,8 +13650,8 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) /* chdir to our dir handle and open the present working directory */ if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) { - PerlDir_close(pwd); - return (DIR *)NULL; + PerlDir_close(pwd); + return (DIR *)NULL; } /* Now we should have two dir handles pointing to the same dir. */ @@ -13671,7 +13671,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) tion. Then step back. */ pos = PerlDir_tell(dp); if ((dirent = PerlDir_read(dp))) { - len = d_namlen(dirent); + len = d_namlen(dirent); if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) { /* If the len is somehow magically longer than the * maximum length of the directory entry, even though @@ -13680,45 +13680,45 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) PerlDir_close(ret); return (DIR*)NULL; } - if (len <= sizeof smallbuf) name = smallbuf; - else Newx(name, len, char); - Move(dirent->d_name, name, len, char); + if (len <= sizeof smallbuf) name = smallbuf; + else Newx(name, len, char); + Move(dirent->d_name, name, len, char); } PerlDir_seek(dp, pos); /* Iterate through the new dir handle, till we find a file with the right name. */ if (!dirent) /* just before the end */ - for(;;) { - pos = PerlDir_tell(ret); - if (PerlDir_read(ret)) continue; /* not there yet */ - PerlDir_seek(ret, pos); /* step back */ - break; - } + for(;;) { + pos = PerlDir_tell(ret); + if (PerlDir_read(ret)) continue; /* not there yet */ + PerlDir_seek(ret, pos); /* step back */ + break; + } else { - const long pos0 = PerlDir_tell(ret); - for(;;) { - pos = PerlDir_tell(ret); - if ((dirent = PerlDir_read(ret))) { - if (len == (STRLEN)d_namlen(dirent) + const long pos0 = PerlDir_tell(ret); + for(;;) { + pos = PerlDir_tell(ret); + if ((dirent = PerlDir_read(ret))) { + if (len == (STRLEN)d_namlen(dirent) && memEQ(name, dirent->d_name, len)) { - /* found it */ - PerlDir_seek(ret, pos); /* step back */ - break; - } - /* else we are not there yet; keep iterating */ - } - else { /* This is not meant to happen. The best we can do is - reset the iterator to the beginning. */ - PerlDir_seek(ret, pos0); - break; - } - } + /* found it */ + PerlDir_seek(ret, pos); /* step back */ + break; + } + /* else we are not there yet; keep iterating */ + } + else { /* This is not meant to happen. The best we can do is + reset the iterator to the beginning. */ + PerlDir_seek(ret, pos0); + break; + } + } } #undef d_namlen if (name && name != smallbuf) - Safefree(name); + Safefree(name); #endif #ifdef WIN32 @@ -13727,7 +13727,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) /* pop it in the pointer table */ if (ret) - ptr_table_store(PL_ptr_table, dp, ret); + ptr_table_store(PL_ptr_table, dp, ret); return ret; } @@ -13742,11 +13742,11 @@ Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_GP_DUP; if (!gp) - return (GP*)NULL; + return (GP*)NULL; /* look for it in the table first */ ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); if (ret) - return ret; + return ret; /* create anew and remember what it is */ Newxz(ret, 1, GP); @@ -13779,60 +13779,60 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_MG_DUP; 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); - - /* There was a comment "XXX copy dynamic vtable?" but as we don't have - dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates - from the original commit adding Perl_mg_dup() - revision 4538. - Similarly there is the annotation "XXX random ptr?" next to the - assignment to nmg->mg_ptr. */ - *nmg = *mg; - - /* FIXME for plugins - if (nmg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); - } - else - */ - nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) - ? nmg->mg_type == PERL_MAGIC_backref - /* The backref AV has its reference - * count deliberately bumped by 1 */ - ? SvREFCNT_inc(av_dup_inc((const AV *) - nmg->mg_obj, param)) - : sv_dup_inc(nmg->mg_obj, param) + 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); + + /* There was a comment "XXX copy dynamic vtable?" but as we don't have + dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates + from the original commit adding Perl_mg_dup() - revision 4538. + Similarly there is the annotation "XXX random ptr?" next to the + assignment to nmg->mg_ptr. */ + *nmg = *mg; + + /* FIXME for plugins + if (nmg->mg_type == PERL_MAGIC_qr) { + nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); + } + else + */ + nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) + ? nmg->mg_type == PERL_MAGIC_backref + /* The backref AV has its reference + * count deliberately bumped by 1 */ + ? SvREFCNT_inc(av_dup_inc((const AV *) + nmg->mg_obj, param)) + : sv_dup_inc(nmg->mg_obj, param) : (nmg->mg_type == PERL_MAGIC_regdatum || nmg->mg_type == PERL_MAGIC_regdata) ? nmg->mg_obj : sv_dup(nmg->mg_obj, param); - if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { - if (nmg->mg_len > 0) { - nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); - if (nmg->mg_type == PERL_MAGIC_overload_table && - AMT_AMAGIC((AMT*)nmg->mg_ptr)) - { - AMT * const namtp = (AMT*)nmg->mg_ptr; - sv_dup_inc_multiple((SV**)(namtp->table), - (SV**)(namtp->table), NofAMmeth, param); - } - } - else if (nmg->mg_len == HEf_SVKEY) - nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); - } - if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { - nmg->mg_virtual->svt_dup(aTHX_ nmg, param); - } + if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { + if (nmg->mg_len > 0) { + nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); + if (nmg->mg_type == PERL_MAGIC_overload_table && + AMT_AMAGIC((AMT*)nmg->mg_ptr)) + { + AMT * const namtp = (AMT*)nmg->mg_ptr; + sv_dup_inc_multiple((SV**)(namtp->table), + (SV**)(namtp->table), NofAMmeth, param); + } + } + else if (nmg->mg_len == HEf_SVKEY) + nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); + } + if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { + nmg->mg_virtual->svt_dup(aTHX_ nmg, param); + } } return mgret; } @@ -13877,8 +13877,8 @@ S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { - if (tblent->oldval == sv) - return tblent; + if (tblent->oldval == sv) + return tblent; } return NULL; } @@ -13907,29 +13907,29 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void * PERL_UNUSED_CONTEXT; if (tblent) { - tblent->newval = newsv; + tblent->newval = newsv; } else { - const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; + const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; - if (tbl->tbl_arena_next == tbl->tbl_arena_end) { - struct ptr_tbl_arena *new_arena; + if (tbl->tbl_arena_next == tbl->tbl_arena_end) { + struct ptr_tbl_arena *new_arena; - Newx(new_arena, 1, struct ptr_tbl_arena); - new_arena->next = tbl->tbl_arena; - tbl->tbl_arena = new_arena; - tbl->tbl_arena_next = new_arena->array; - tbl->tbl_arena_end = C_ARRAY_END(new_arena->array); - } + Newx(new_arena, 1, struct ptr_tbl_arena); + new_arena->next = tbl->tbl_arena; + tbl->tbl_arena = new_arena; + tbl->tbl_arena_next = new_arena->array; + tbl->tbl_arena_end = C_ARRAY_END(new_arena->array); + } - tblent = tbl->tbl_arena_next++; + tblent = tbl->tbl_arena_next++; - tblent->oldval = oldsv; - tblent->newval = newsv; - tblent->next = tbl->tbl_ary[entry]; - tbl->tbl_ary[entry] = tblent; - tbl->tbl_items++; - if (tblent->next && tbl->tbl_items > tbl->tbl_max) - ptr_table_split(tbl); + tblent->oldval = oldsv; + tblent->newval = newsv; + tblent->next = tbl->tbl_ary[entry]; + tbl->tbl_ary[entry] = tblent; + tbl->tbl_items++; + if (tblent->next && tbl->tbl_items > tbl->tbl_max) + ptr_table_split(tbl); } } @@ -13951,22 +13951,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) tbl->tbl_max = --newsize; tbl->tbl_ary = ary; for (i=0; i < oldsize; i++, ary++) { - PTR_TBL_ENT_t **entp = ary; - PTR_TBL_ENT_t *ent = *ary; - PTR_TBL_ENT_t **curentp; - if (!ent) - continue; - curentp = ary + oldsize; - do { - if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { - *entp = ent->next; - ent->next = *curentp; - *curentp = ent; - } - else - entp = &ent->next; - ent = *entp; - } while (ent); + PTR_TBL_ENT_t **entp = ary; + PTR_TBL_ENT_t *ent = *ary; + PTR_TBL_ENT_t **curentp; + if (!ent) + continue; + curentp = ary + oldsize; + do { + if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + } + else + entp = &ent->next; + ent = *entp; + } while (ent); } } @@ -13978,21 +13978,21 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { PERL_UNUSED_CONTEXT; if (tbl && tbl->tbl_items) { - struct ptr_tbl_arena *arena = tbl->tbl_arena; + struct ptr_tbl_arena *arena = tbl->tbl_arena; - Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *); + Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *); - while (arena) { - struct ptr_tbl_arena *next = arena->next; + while (arena) { + struct ptr_tbl_arena *next = arena->next; - Safefree(arena); - arena = next; - }; + Safefree(arena); + arena = next; + }; - tbl->tbl_items = 0; - tbl->tbl_arena = NULL; - tbl->tbl_arena_next = NULL; - tbl->tbl_arena_end = NULL; + tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; } } @@ -14012,10 +14012,10 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) arena = tbl->tbl_arena; while (arena) { - struct ptr_tbl_arena *next = arena->next; + struct ptr_tbl_arena *next = arena->next; - Safefree(arena); - arena = next; + Safefree(arena); + arena = next; } Safefree(tbl->tbl_ary); @@ -14031,58 +14031,58 @@ Perl_rvpv_dup(pTHX_ SV *const dsv, const SV *const ssv, CLONE_PARAMS *const para assert(!isREGEXP(ssv)); if (SvROK(ssv)) { - if (SvWEAKREF(ssv)) { - SvRV_set(dsv, sv_dup(SvRV_const(ssv), 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(dsv), dsv); - } - } - else - SvRV_set(dsv, sv_dup_inc(SvRV_const(ssv), param)); + if (SvWEAKREF(ssv)) { + SvRV_set(dsv, sv_dup(SvRV_const(ssv), 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(dsv), dsv); + } + } + else + SvRV_set(dsv, sv_dup_inc(SvRV_const(ssv), param)); } else if (SvPVX_const(ssv)) { - /* Has something there */ - if (SvLEN(ssv)) { - /* Normal PV - clone whole allocated space */ - SvPV_set(dsv, SAVEPVN(SvPVX_const(ssv), SvLEN(ssv)-1)); - /* ssv may not be that normal, but actually copy on write. - But we are a true, independent SV, so: */ - SvIsCOW_off(dsv); - } - else { - /* Special case - not normally malloced for some reason */ - if (isGV_with_GP(ssv)) { - /* Don't need to do anything here. */ - } - else if ((SvIsCOW(ssv))) { - /* A "shared" PV - clone it as "shared" PV */ - SvPV_set(dsv, - HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)), - param))); - } - else { - /* Some other special case - random pointer */ - SvPV_set(dsv, (char *) SvPVX_const(ssv)); - } - } + /* Has something there */ + if (SvLEN(ssv)) { + /* Normal PV - clone whole allocated space */ + SvPV_set(dsv, SAVEPVN(SvPVX_const(ssv), SvLEN(ssv)-1)); + /* ssv may not be that normal, but actually copy on write. + But we are a true, independent SV, so: */ + SvIsCOW_off(dsv); + } + else { + /* Special case - not normally malloced for some reason */ + if (isGV_with_GP(ssv)) { + /* Don't need to do anything here. */ + } + else if ((SvIsCOW(ssv))) { + /* A "shared" PV - clone it as "shared" PV */ + SvPV_set(dsv, + HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)), + param))); + } + else { + /* Some other special case - random pointer */ + SvPV_set(dsv, (char *) SvPVX_const(ssv)); + } + } } else { - /* Copy the NULL */ - SvPV_set(dsv, NULL); + /* Copy the NULL */ + SvPV_set(dsv, NULL); } } /* duplicate a list of SVs. source and dest may point to the same memory. */ static SV ** S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, - SSize_t items, CLONE_PARAMS *const param) + SSize_t items, CLONE_PARAMS *const param) { PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE; while (items-- > 0) { - *dest++ = sv_dup_inc(*source++, param); + *dest++ = sv_dup_inc(*source++, param); } return dest; @@ -14099,48 +14099,48 @@ S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) if (SvTYPE(ssv) == (svtype)SVTYPEMASK) { #ifdef DEBUG_LEAKING_SCALARS_ABORT - abort(); + abort(); #endif - return NULL; + return NULL; } /* look for it in the table first */ dsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, ssv)); if (dsv) - return dsv; + return dsv; if(param->flags & CLONEf_JOIN_IN) { /** We are joining here so we don't want do clone - something that is bad **/ - if (SvTYPE(ssv) == SVt_PVHV) { - const HEK * const hvname = HvNAME_HEK(ssv); - if (hvname) { - /** don't clone stashes if they already exist **/ - dsv = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), + something that is bad **/ + if (SvTYPE(ssv) == SVt_PVHV) { + const HEK * const hvname = HvNAME_HEK(ssv); + if (hvname) { + /** don't clone stashes if they already exist **/ + dsv = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), HEK_UTF8(hvname) ? SVf_UTF8 : 0)); - ptr_table_store(PL_ptr_table, ssv, dsv); - return dsv; - } - } - else if (SvTYPE(ssv) == SVt_PVGV && !SvFAKE(ssv)) { - HV *stash = GvSTASH(ssv); - const HEK * hvname; - if (stash && (hvname = HvNAME_HEK(stash))) { - /** don't clone GVs if they already exist **/ - SV **svp; - stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), - HEK_UTF8(hvname) ? SVf_UTF8 : 0); - svp = hv_fetch( - stash, GvNAME(ssv), - GvNAMEUTF8(ssv) - ? -GvNAMELEN(ssv) - : GvNAMELEN(ssv), - 0 - ); - if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { - ptr_table_store(PL_ptr_table, ssv, *svp); - return *svp; - } - } + ptr_table_store(PL_ptr_table, ssv, dsv); + return dsv; + } + } + else if (SvTYPE(ssv) == SVt_PVGV && !SvFAKE(ssv)) { + HV *stash = GvSTASH(ssv); + const HEK * hvname; + if (stash && (hvname = HvNAME_HEK(stash))) { + /** don't clone GVs if they already exist **/ + SV **svp; + stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), + HEK_UTF8(hvname) ? SVf_UTF8 : 0); + svp = hv_fetch( + stash, GvNAME(ssv), + GvNAMEUTF8(ssv) + ? -GvNAMELEN(ssv) + : GvNAMELEN(ssv), + 0 + ); + if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { + ptr_table_store(PL_ptr_table, ssv, *svp); + return *svp; + } + } } } @@ -14165,345 +14165,345 @@ S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) #ifdef DEBUGGING if (SvANY(ssv) && PL_watch_pvx && SvPVX_const(ssv) == PL_watch_pvx) - PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - (void*)PL_watch_pvx, SvPVX_const(ssv)); + PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", + (void*)PL_watch_pvx, SvPVX_const(ssv)); #endif /* don't clone objects whose class has asked us not to */ if (SvOBJECT(ssv) && ! (SvFLAGS(SvSTASH(ssv)) & SVphv_CLONEABLE)) { - SvFLAGS(dsv) = 0; - return dsv; + SvFLAGS(dsv) = 0; + return dsv; } switch (SvTYPE(ssv)) { case SVt_NULL: - SvANY(dsv) = NULL; - break; + SvANY(dsv) = NULL; + break; case SVt_IV: - SET_SVANY_FOR_BODYLESS_IV(dsv); - if(SvROK(ssv)) { - Perl_rvpv_dup(aTHX_ dsv, ssv, param); - } else { - SvIV_set(dsv, SvIVX(ssv)); - } - break; + SET_SVANY_FOR_BODYLESS_IV(dsv); + if(SvROK(ssv)) { + Perl_rvpv_dup(aTHX_ dsv, ssv, param); + } else { + SvIV_set(dsv, SvIVX(ssv)); + } + break; case SVt_NV: #if NVSIZE <= IVSIZE - SET_SVANY_FOR_BODYLESS_NV(dsv); + SET_SVANY_FOR_BODYLESS_NV(dsv); #else - SvANY(dsv) = new_XNV(); + SvANY(dsv) = new_XNV(); #endif - SvNV_set(dsv, SvNVX(ssv)); - break; + SvNV_set(dsv, SvNVX(ssv)); + break; default: - { - /* These are all the types that need complex bodies allocating. */ - void *new_body; - const svtype sv_type = SvTYPE(ssv); - const struct body_details *const sv_type_details - = bodies_by_type + sv_type; - - switch (sv_type) { - default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv)); + { + /* These are all the types that need complex bodies allocating. */ + void *new_body; + const svtype sv_type = SvTYPE(ssv); + const struct body_details *const sv_type_details + = bodies_by_type + sv_type; + + switch (sv_type) { + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv)); NOT_REACHED; /* NOTREACHED */ - break; - - case SVt_PVGV: - case SVt_PVIO: - case SVt_PVFM: - case SVt_PVHV: - case SVt_PVAV: - case SVt_PVCV: - case SVt_PVLV: - case SVt_REGEXP: - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: + break; + + case SVt_PVGV: + case SVt_PVIO: + case SVt_PVFM: + case SVt_PVHV: + case SVt_PVAV: + case SVt_PVCV: + case SVt_PVLV: + case SVt_REGEXP: + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: case SVt_INVLIST: - case SVt_PV: - assert(sv_type_details->body_size); - if (sv_type_details->arena) { - new_body_inline(new_body, sv_type); - new_body - = (void*)((char*)new_body - sv_type_details->offset); - } else { - new_body = new_NOARENA(sv_type_details); - } - } - assert(new_body); - SvANY(dsv) = new_body; + case SVt_PV: + assert(sv_type_details->body_size); + if (sv_type_details->arena) { + new_body_inline(new_body, sv_type); + new_body + = (void*)((char*)new_body - sv_type_details->offset); + } else { + new_body = new_NOARENA(sv_type_details); + } + } + assert(new_body); + SvANY(dsv) = new_body; #ifndef PURIFY - Copy(((char*)SvANY(ssv)) + sv_type_details->offset, - ((char*)SvANY(dsv)) + sv_type_details->offset, - sv_type_details->copy, char); + Copy(((char*)SvANY(ssv)) + sv_type_details->offset, + ((char*)SvANY(dsv)) + sv_type_details->offset, + sv_type_details->copy, char); #else - Copy(((char*)SvANY(ssv)), - ((char*)SvANY(dsv)), - sv_type_details->body_size + sv_type_details->offset, char); + Copy(((char*)SvANY(ssv)), + ((char*)SvANY(dsv)), + sv_type_details->body_size + sv_type_details->offset, char); #endif - if (sv_type != SVt_PVAV && sv_type != SVt_PVHV - && !isGV_with_GP(dsv) - && !isREGEXP(dsv) - && !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP))) - Perl_rvpv_dup(aTHX_ dsv, ssv, param); - - /* The Copy above means that all the source (unduplicated) pointers - are now in the destination. We can check the flags and the - pointers in either, but it's possible that there's less cache - missing by always going for the destination. - FIXME - instrument and check that assumption */ - if (sv_type >= SVt_PVMG) { - if (SvMAGIC(dsv)) - SvMAGIC_set(dsv, mg_dup(SvMAGIC(dsv), param)); - if (SvOBJECT(dsv) && SvSTASH(dsv)) - SvSTASH_set(dsv, hv_dup_inc(SvSTASH(dsv), param)); - else SvSTASH_set(dsv, 0); /* don't copy DESTROY cache */ - } - - /* The cast silences a GCC warning about unhandled types. */ - switch ((int)sv_type) { - case SVt_PV: - break; - case SVt_PVIV: - break; - case SVt_PVNV: - break; - case SVt_PVMG: - break; - case SVt_REGEXP: - duprex: - /* FIXME for plugins */ - re_dup_guts((REGEXP*) ssv, (REGEXP*) dsv, param); - break; - case SVt_PVLV: - /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ - if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */ - LvTARG(dsv) = dsv; - else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */ - LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), 0, param)); - else - LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param); - if (isREGEXP(ssv)) goto duprex; - /* FALLTHROUGH */ - case SVt_PVGV: - /* non-GP case already handled above */ - if(isGV_with_GP(ssv)) { - GvNAME_HEK(dsv) = hek_dup(GvNAME_HEK(dsv), param); - /* Don't call sv_add_backref here as it's going to be - created as part of the magic cloning of the symbol - table--unless this is during a join and the stash - is not actually being cloned. */ - /* Danger Will Robinson - GvGP(dsv) isn't initialised - at the point of this comment. */ - GvSTASH(dsv) = hv_dup(GvSTASH(dsv), param); - if (param->flags & CLONEf_JOIN_IN) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); - GvGP_set(dsv, gp_dup(GvGP(ssv), param)); - (void)GpREFCNT_inc(GvGP(dsv)); - } - break; - case SVt_PVIO: - /* PL_parser->rsfp_filters entries have fake IoDIRP() */ - if(IoFLAGS(dsv) & IOf_FAKE_DIRP) { - /* I have no idea why fake dirp (rsfps) - should be treated differently but otherwise - we end up with leaks -- sky*/ - IoTOP_GV(dsv) = gv_dup_inc(IoTOP_GV(dsv), param); - IoFMT_GV(dsv) = gv_dup_inc(IoFMT_GV(dsv), param); - IoBOTTOM_GV(dsv) = gv_dup_inc(IoBOTTOM_GV(dsv), param); - } else { - IoTOP_GV(dsv) = gv_dup(IoTOP_GV(dsv), param); - IoFMT_GV(dsv) = gv_dup(IoFMT_GV(dsv), param); - IoBOTTOM_GV(dsv) = gv_dup(IoBOTTOM_GV(dsv), param); - if (IoDIRP(dsv)) { - IoDIRP(dsv) = dirp_dup(IoDIRP(dsv), param); - } else { - NOOP; - /* IoDIRP(dsv) is already a copy of IoDIRP(ssv) */ - } - IoIFP(dsv) = fp_dup(IoIFP(ssv), IoTYPE(dsv), param); - } - if (IoOFP(dsv) == IoIFP(ssv)) - IoOFP(dsv) = IoIFP(dsv); - else - IoOFP(dsv) = fp_dup(IoOFP(dsv), IoTYPE(dsv), param); - IoTOP_NAME(dsv) = SAVEPV(IoTOP_NAME(dsv)); - IoFMT_NAME(dsv) = SAVEPV(IoFMT_NAME(dsv)); - IoBOTTOM_NAME(dsv) = SAVEPV(IoBOTTOM_NAME(dsv)); - break; - case SVt_PVAV: - /* avoid cloning an empty array */ - if (AvARRAY((const AV *)ssv) && AvFILLp((const AV *)ssv) >= 0) { - SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((const AV *)ssv) + 1; - - src_ary = AvARRAY((const AV *)ssv); - Newx(dst_ary, AvMAX((const AV *)ssv)+1, SV*); - ptr_table_store(PL_ptr_table, src_ary, dst_ary); - AvARRAY(MUTABLE_AV(dsv)) = dst_ary; - AvALLOC((const AV *)dsv) = dst_ary; - if (AvREAL((const AV *)ssv)) { - dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, - param); - } - else { - while (items-- > 0) - *dst_ary++ = sv_dup(*src_ary++, param); - } - items = AvMAX((const AV *)ssv) - AvFILLp((const AV *)ssv); - while (items-- > 0) { - *dst_ary++ = NULL; - } - } - else { - AvARRAY(MUTABLE_AV(dsv)) = NULL; - AvALLOC((const AV *)dsv) = (SV**)NULL; - AvMAX( (const AV *)dsv) = -1; - AvFILLp((const AV *)dsv) = -1; - } - break; - case SVt_PVHV: - if (HvARRAY((const HV *)ssv)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(ssv); - XPVHV * const dxhv = (XPVHV*)SvANY(dsv); - XPVHV * const sxhv = (XPVHV*)SvANY(ssv); - char *darray; - Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(ssv) ? sizeof(struct xpvhv_aux) : 0), - char); - HvARRAY(dsv) = (HE**)darray; - while (i <= sxhv->xhv_max) { - const HE * const source = HvARRAY(ssv)[i]; - HvARRAY(dsv)[i] = source - ? he_dup(source, sharekeys, param) : 0; - ++i; - } - if (SvOOK(ssv)) { - const struct xpvhv_aux * const saux = HvAUX(ssv); - struct xpvhv_aux * const daux = HvAUX(dsv); - /* This flag isn't copied. */ - SvOOK_on(dsv); - - if (saux->xhv_name_count) { - HEK ** const sname = saux->xhv_name_u.xhvnameu_names; - const I32 count - = saux->xhv_name_count < 0 - ? -saux->xhv_name_count - : saux->xhv_name_count; - HEK **shekp = sname + count; - HEK **dhekp; - Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); - dhekp = daux->xhv_name_u.xhvnameu_names + count; - while (shekp-- > sname) { - dhekp--; - *dhekp = hek_dup(*shekp, param); - } - } - else { - daux->xhv_name_u.xhvnameu_name - = hek_dup(saux->xhv_name_u.xhvnameu_name, - param); - } - daux->xhv_name_count = saux->xhv_name_count; - - daux->xhv_aux_flags = saux->xhv_aux_flags; + if (sv_type != SVt_PVAV && sv_type != SVt_PVHV + && !isGV_with_GP(dsv) + && !isREGEXP(dsv) + && !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP))) + Perl_rvpv_dup(aTHX_ dsv, ssv, param); + + /* The Copy above means that all the source (unduplicated) pointers + are now in the destination. We can check the flags and the + pointers in either, but it's possible that there's less cache + missing by always going for the destination. + FIXME - instrument and check that assumption */ + if (sv_type >= SVt_PVMG) { + if (SvMAGIC(dsv)) + SvMAGIC_set(dsv, mg_dup(SvMAGIC(dsv), param)); + if (SvOBJECT(dsv) && SvSTASH(dsv)) + SvSTASH_set(dsv, hv_dup_inc(SvSTASH(dsv), param)); + else SvSTASH_set(dsv, 0); /* don't copy DESTROY cache */ + } + + /* The cast silences a GCC warning about unhandled types. */ + switch ((int)sv_type) { + case SVt_PV: + break; + case SVt_PVIV: + break; + case SVt_PVNV: + break; + case SVt_PVMG: + break; + case SVt_REGEXP: + duprex: + /* FIXME for plugins */ + re_dup_guts((REGEXP*) ssv, (REGEXP*) dsv, param); + break; + case SVt_PVLV: + /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ + if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dsv) = dsv; + else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */ + LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), 0, param)); + else + LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param); + if (isREGEXP(ssv)) goto duprex; + /* FALLTHROUGH */ + case SVt_PVGV: + /* non-GP case already handled above */ + if(isGV_with_GP(ssv)) { + GvNAME_HEK(dsv) = hek_dup(GvNAME_HEK(dsv), param); + /* Don't call sv_add_backref here as it's going to be + created as part of the magic cloning of the symbol + table--unless this is during a join and the stash + is not actually being cloned. */ + /* Danger Will Robinson - GvGP(dsv) isn't initialised + at the point of this comment. */ + GvSTASH(dsv) = hv_dup(GvSTASH(dsv), param); + if (param->flags & CLONEf_JOIN_IN) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); + GvGP_set(dsv, gp_dup(GvGP(ssv), param)); + (void)GpREFCNT_inc(GvGP(dsv)); + } + break; + case SVt_PVIO: + /* PL_parser->rsfp_filters entries have fake IoDIRP() */ + if(IoFLAGS(dsv) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treated differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dsv) = gv_dup_inc(IoTOP_GV(dsv), param); + IoFMT_GV(dsv) = gv_dup_inc(IoFMT_GV(dsv), param); + IoBOTTOM_GV(dsv) = gv_dup_inc(IoBOTTOM_GV(dsv), param); + } else { + IoTOP_GV(dsv) = gv_dup(IoTOP_GV(dsv), param); + IoFMT_GV(dsv) = gv_dup(IoFMT_GV(dsv), param); + IoBOTTOM_GV(dsv) = gv_dup(IoBOTTOM_GV(dsv), param); + if (IoDIRP(dsv)) { + IoDIRP(dsv) = dirp_dup(IoDIRP(dsv), param); + } else { + NOOP; + /* IoDIRP(dsv) is already a copy of IoDIRP(ssv) */ + } + IoIFP(dsv) = fp_dup(IoIFP(ssv), IoTYPE(dsv), param); + } + if (IoOFP(dsv) == IoIFP(ssv)) + IoOFP(dsv) = IoIFP(dsv); + else + IoOFP(dsv) = fp_dup(IoOFP(dsv), IoTYPE(dsv), param); + IoTOP_NAME(dsv) = SAVEPV(IoTOP_NAME(dsv)); + IoFMT_NAME(dsv) = SAVEPV(IoFMT_NAME(dsv)); + IoBOTTOM_NAME(dsv) = SAVEPV(IoBOTTOM_NAME(dsv)); + break; + case SVt_PVAV: + /* avoid cloning an empty array */ + if (AvARRAY((const AV *)ssv) && AvFILLp((const AV *)ssv) >= 0) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((const AV *)ssv) + 1; + + src_ary = AvARRAY((const AV *)ssv); + Newx(dst_ary, AvMAX((const AV *)ssv)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); + AvARRAY(MUTABLE_AV(dsv)) = dst_ary; + AvALLOC((const AV *)dsv) = dst_ary; + if (AvREAL((const AV *)ssv)) { + dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, + param); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++, param); + } + items = AvMAX((const AV *)ssv) - AvFILLp((const AV *)ssv); + while (items-- > 0) { + *dst_ary++ = NULL; + } + } + else { + AvARRAY(MUTABLE_AV(dsv)) = NULL; + AvALLOC((const AV *)dsv) = (SV**)NULL; + AvMAX( (const AV *)dsv) = -1; + AvFILLp((const AV *)dsv) = -1; + } + break; + case SVt_PVHV: + if (HvARRAY((const HV *)ssv)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(ssv); + XPVHV * const dxhv = (XPVHV*)SvANY(dsv); + XPVHV * const sxhv = (XPVHV*)SvANY(ssv); + char *darray; + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(ssv) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dsv) = (HE**)darray; + while (i <= sxhv->xhv_max) { + const HE * const source = HvARRAY(ssv)[i]; + HvARRAY(dsv)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(ssv)) { + const struct xpvhv_aux * const saux = HvAUX(ssv); + struct xpvhv_aux * const daux = HvAUX(dsv); + /* This flag isn't copied. */ + SvOOK_on(dsv); + + if (saux->xhv_name_count) { + HEK ** const sname = saux->xhv_name_u.xhvnameu_names; + const I32 count + = saux->xhv_name_count < 0 + ? -saux->xhv_name_count + : saux->xhv_name_count; + HEK **shekp = sname + count; + HEK **dhekp; + Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); + dhekp = daux->xhv_name_u.xhvnameu_names + count; + while (shekp-- > sname) { + dhekp--; + *dhekp = hek_dup(*shekp, param); + } + } + else { + daux->xhv_name_u.xhvnameu_name + = hek_dup(saux->xhv_name_u.xhvnameu_name, + param); + } + daux->xhv_name_count = saux->xhv_name_count; + + daux->xhv_aux_flags = saux->xhv_aux_flags; #ifdef PERL_HASH_RANDOMIZE_KEYS - daux->xhv_rand = saux->xhv_rand; - daux->xhv_last_rand = saux->xhv_last_rand; + daux->xhv_rand = saux->xhv_rand; + daux->xhv_last_rand = saux->xhv_last_rand; #endif - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, - cBOOL(HvSHAREKEYS(ssv)), param) : 0; - /* backref array needs refcnt=2; see sv_add_backref */ - daux->xhv_backreferences = - (param->flags & CLONEf_JOIN_IN) - /* when joining, we let the individual GVs and - * CVs add themselves to backref as - * needed. This avoids pulling in stuff - * that isn't required, and simplifies the - * case where stashes aren't cloned back - * if they already exist in the parent - * thread */ - ? NULL - : saux->xhv_backreferences - ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) - ? MUTABLE_AV(SvREFCNT_inc( - sv_dup_inc((const SV *) - saux->xhv_backreferences, param))) - : MUTABLE_AV(sv_dup((const SV *) - saux->xhv_backreferences, param)) - : 0; + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + cBOOL(HvSHAREKEYS(ssv)), param) : 0; + /* backref array needs refcnt=2; see sv_add_backref */ + daux->xhv_backreferences = + (param->flags & CLONEf_JOIN_IN) + /* when joining, we let the individual GVs and + * CVs add themselves to backref as + * needed. This avoids pulling in stuff + * that isn't required, and simplifies the + * case where stashes aren't cloned back + * if they already exist in the parent + * thread */ + ? NULL + : saux->xhv_backreferences + ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) + ? MUTABLE_AV(SvREFCNT_inc( + sv_dup_inc((const SV *) + saux->xhv_backreferences, param))) + : MUTABLE_AV(sv_dup((const SV *) + saux->xhv_backreferences, param)) + : 0; daux->xhv_mro_meta = saux->xhv_mro_meta ? mro_meta_dup(saux->xhv_mro_meta, param) : 0; - /* Record stashes for possible cloning in Perl_clone(). */ - if (HvNAME(ssv)) - av_push(param->stashes, dsv); - } - } - else - HvARRAY(MUTABLE_HV(dsv)) = NULL; - break; - case SVt_PVCV: - if (!(param->flags & CLONEf_COPY_STACKS)) { - CvDEPTH(dsv) = 0; - } - /* FALLTHROUGH */ - case SVt_PVFM: - /* NOTE: not refcounted */ - SvANY(MUTABLE_CV(dsv))->xcv_stash = - hv_dup(CvSTASH(dsv), param); - if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dsv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dsv)), dsv); - if (!CvISXSUB(dsv)) { - OP_REFCNT_LOCK; - CvROOT(dsv) = OpREFCNT_inc(CvROOT(dsv)); - OP_REFCNT_UNLOCK; - CvSLABBED_off(dsv); - } else if (CvCONST(dsv)) { - CvXSUBANY(dsv).any_ptr = - sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param); - } - assert(!CvSLABBED(dsv)); - if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv)); - if (CvNAMED(dsv)) - SvANY((CV *)dsv)->xcv_gv_u.xcv_hek = - hek_dup(CvNAME_HEK((CV *)ssv), param); - /* don't dup if copying back - CvGV isn't refcounted, so the - * duped GV may never be freed. A bit of a hack! DAPM */ - else - SvANY(MUTABLE_CV(dsv))->xcv_gv_u.xcv_gv = - CvCVGV_RC(dsv) - ? gv_dup_inc(CvGV(ssv), param) - : (param->flags & CLONEf_JOIN_IN) - ? NULL - : gv_dup(CvGV(ssv), param); - - if (!CvISXSUB(ssv)) { - PADLIST * padlist = CvPADLIST(ssv); - if(padlist) - padlist = padlist_dup(padlist, param); - CvPADLIST_set(dsv, padlist); - } else + /* Record stashes for possible cloning in Perl_clone(). */ + if (HvNAME(ssv)) + av_push(param->stashes, dsv); + } + } + else + HvARRAY(MUTABLE_HV(dsv)) = NULL; + break; + case SVt_PVCV: + if (!(param->flags & CLONEf_COPY_STACKS)) { + CvDEPTH(dsv) = 0; + } + /* FALLTHROUGH */ + case SVt_PVFM: + /* NOTE: not refcounted */ + SvANY(MUTABLE_CV(dsv))->xcv_stash = + hv_dup(CvSTASH(dsv), param); + if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dsv)) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dsv)), dsv); + if (!CvISXSUB(dsv)) { + OP_REFCNT_LOCK; + CvROOT(dsv) = OpREFCNT_inc(CvROOT(dsv)); + OP_REFCNT_UNLOCK; + CvSLABBED_off(dsv); + } else if (CvCONST(dsv)) { + CvXSUBANY(dsv).any_ptr = + sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param); + } + assert(!CvSLABBED(dsv)); + if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv)); + if (CvNAMED(dsv)) + SvANY((CV *)dsv)->xcv_gv_u.xcv_hek = + hek_dup(CvNAME_HEK((CV *)ssv), param); + /* don't dup if copying back - CvGV isn't refcounted, so the + * duped GV may never be freed. A bit of a hack! DAPM */ + else + SvANY(MUTABLE_CV(dsv))->xcv_gv_u.xcv_gv = + CvCVGV_RC(dsv) + ? gv_dup_inc(CvGV(ssv), param) + : (param->flags & CLONEf_JOIN_IN) + ? NULL + : gv_dup(CvGV(ssv), param); + + if (!CvISXSUB(ssv)) { + PADLIST * padlist = CvPADLIST(ssv); + if(padlist) + padlist = padlist_dup(padlist, param); + CvPADLIST_set(dsv, padlist); + } else /* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */ - PoisonPADLIST(dsv); + PoisonPADLIST(dsv); - CvOUTSIDE(dsv) = - CvWEAKOUTSIDE(ssv) - ? cv_dup( CvOUTSIDE(dsv), param) - : cv_dup_inc(CvOUTSIDE(dsv), param); - break; - } - } + CvOUTSIDE(dsv) = + CvWEAKOUTSIDE(ssv) + ? cv_dup( CvOUTSIDE(dsv), param) + : cv_dup_inc(CvOUTSIDE(dsv), param); + break; + } + } } return dsv; @@ -14537,8 +14537,8 @@ Perl_sv_dup(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) to be in use, and free to be re-used. Not good. */ if (dsv && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dsv)) { - assert(param->unreferenced); - av_push(param->unreferenced, SvREFCNT_inc(dsv)); + assert(param->unreferenced); + av_push(param->unreferenced, SvREFCNT_inc(dsv)); } return dsv; @@ -14554,12 +14554,12 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) PERL_ARGS_ASSERT_CX_DUP; if (!cxs) - return (PERL_CONTEXT*)NULL; + return (PERL_CONTEXT*)NULL; /* look for it in the table first */ ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); if (ncxs) - return ncxs; + return ncxs; /* create anew and remember what it is */ Newx(ncxs, max + 1, PERL_CONTEXT); @@ -14567,92 +14567,92 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) Copy(cxs, ncxs, max + 1, PERL_CONTEXT); while (ix >= 0) { - PERL_CONTEXT * const ncx = &ncxs[ix]; - if (CxTYPE(ncx) == CXt_SUBST) { - Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); - } - else { - ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); - switch (CxTYPE(ncx)) { - case CXt_SUB: - ncx->blk_sub.cv = cv_dup_inc(ncx->blk_sub.cv, param); - if(CxHASARGS(ncx)){ - ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param); - } else { - ncx->blk_sub.savearray = NULL; - } - ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - ncx->blk_sub.prevcomppad); - break; - case CXt_EVAL: - ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, - param); + PERL_CONTEXT * const ncx = &ncxs[ix]; + if (CxTYPE(ncx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); + switch (CxTYPE(ncx)) { + case CXt_SUB: + ncx->blk_sub.cv = cv_dup_inc(ncx->blk_sub.cv, param); + if(CxHASARGS(ncx)){ + ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param); + } else { + ncx->blk_sub.savearray = NULL; + } + ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, + ncx->blk_sub.prevcomppad); + break; + 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 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); + 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 to do with cur_top_env ???? */ - break; - case CXt_LOOP_LAZYSV: - ncx->blk_loop.state_u.lazysv.end - = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); + break; + case CXt_LOOP_LAZYSV: + ncx->blk_loop.state_u.lazysv.end + = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); /* Fallthrough: duplicate lazysv.cur by using the ary.ary duplication code instead. We are taking advantage of (1) av_dup_inc and sv_dup_inc actually being the same function, and (2) order equivalence of the two unions. - We can assert the later [but only at run time :-(] */ - assert ((void *) &ncx->blk_loop.state_u.ary.ary == - (void *) &ncx->blk_loop.state_u.lazysv.cur); + We can assert the later [but only at run time :-(] */ + assert ((void *) &ncx->blk_loop.state_u.ary.ary == + (void *) &ncx->blk_loop.state_u.lazysv.cur); /* FALLTHROUGH */ - case CXt_LOOP_ARY: - ncx->blk_loop.state_u.ary.ary - = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); + case CXt_LOOP_ARY: + ncx->blk_loop.state_u.ary.ary + = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); /* FALLTHROUGH */ - case CXt_LOOP_LIST: - case CXt_LOOP_LAZYIV: + case CXt_LOOP_LIST: + case CXt_LOOP_LAZYIV: /* code common to all 'for' CXt_LOOP_* types */ - ncx->blk_loop.itersave = + ncx->blk_loop.itersave = sv_dup_inc(ncx->blk_loop.itersave, param); - if (CxPADLOOP(ncx)) { + if (CxPADLOOP(ncx)) { PADOFFSET off = ncx->blk_loop.itervar_u.svp - &CX_CURPAD_SV(ncx->blk_loop, 0); ncx->blk_loop.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, ncx->blk_loop.oldcomppad); - ncx->blk_loop.itervar_u.svp = + ncx->blk_loop.itervar_u.svp = &CX_CURPAD_SV(ncx->blk_loop, off); } - else { + else { /* this copies the GV if CXp_FOR_GV, or the SV for an * alias (for \$x (...)) - relies on gv_dup being the * same as sv_dup */ - ncx->blk_loop.itervar_u.gv - = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, - param); - } - break; - case CXt_LOOP_PLAIN: - break; - case CXt_FORMAT: - ncx->blk_format.prevcomppad = + ncx->blk_loop.itervar_u.gv + = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, + param); + } + break; + case CXt_LOOP_PLAIN: + break; + case CXt_FORMAT: + ncx->blk_format.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - ncx->blk_format.prevcomppad); - ncx->blk_format.cv = cv_dup_inc(ncx->blk_format.cv, param); - ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); - ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, - param); - break; - case CXt_GIVEN: - ncx->blk_givwhen.defsv_save = + ncx->blk_format.prevcomppad); + ncx->blk_format.cv = cv_dup_inc(ncx->blk_format.cv, param); + ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); + ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, + param); + break; + case CXt_GIVEN: + ncx->blk_givwhen.defsv_save = sv_dup_inc(ncx->blk_givwhen.defsv_save, param); - break; - case CXt_BLOCK: - case CXt_NULL: - case CXt_WHEN: - break; - } - } - --ix; + break; + case CXt_BLOCK: + case CXt_NULL: + case CXt_WHEN: + break; + } + } + --ix; } return ncxs; } @@ -14667,12 +14667,12 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) PERL_ARGS_ASSERT_SI_DUP; if (!si) - return (PERL_SI*)NULL; + return (PERL_SI*)NULL; /* look for it in the table first */ nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); if (nsi) - return nsi; + return nsi; /* create anew and remember what it is */ Newx(nsi, 1, PERL_SI); @@ -14728,18 +14728,18 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) PERL_ARGS_ASSERT_ANY_DUP; if (!v) - return (void*)NULL; + return (void*)NULL; /* look for it in the table first */ ret = ptr_table_fetch(PL_ptr_table, v); if (ret) - return ret; + return ret; /* see if it is part of the interpreter structure */ if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) - ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); + ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); else { - ret = v; + ret = v; } return ret; @@ -14773,255 +14773,255 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newx(nss, max, ANY); while (ix > 0) { - const UV uv = POPUV(ss,ix); - const U8 type = (U8)uv & SAVE_MASK; - - TOPUV(nss,ix) = uv; - switch (type) { - case SAVEt_CLEARSV: - case SAVEt_CLEARPADRANGE: - break; - case SAVEt_HELEM: /* hash element */ - case SAVEt_SV: /* scalar reference */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); - /* FALLTHROUGH */ - case SAVEt_ITEM: /* normal string */ + const UV uv = POPUV(ss,ix); + const U8 type = (U8)uv & SAVE_MASK; + + TOPUV(nss,ix) = uv; + switch (type) { + case SAVEt_CLEARSV: + case SAVEt_CLEARPADRANGE: + break; + case SAVEt_HELEM: /* hash element */ + case SAVEt_SV: /* scalar reference */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); + /* FALLTHROUGH */ + case SAVEt_ITEM: /* normal string */ case SAVEt_GVSV: /* scalar slot in GV */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - if (type == SAVEt_SV) - break; - /* FALLTHROUGH */ - case SAVEt_FREESV: - case SAVEt_MORTALIZESV: - case SAVEt_READONLY_OFF: - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; - case SAVEt_FREEPADNAME: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param); - PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++; - break; - case SAVEt_SHARED_PVREF: /* char* in shared space */ - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = savesharedpv(c); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - break; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + if (type == SAVEt_SV) + break; + /* FALLTHROUGH */ + case SAVEt_FREESV: + case SAVEt_MORTALIZESV: + case SAVEt_READONLY_OFF: + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; + case SAVEt_FREEPADNAME: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param); + PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++; + break; + case SAVEt_SHARED_PVREF: /* char* in shared space */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = savesharedpv(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - if (type == SAVEt_SVREF) - SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix)); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ - break; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + if (type == SAVEt_SVREF) + SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix)); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; case SAVEt_GVSLOT: /* any slot in GV */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = (const SV *) POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - /* FALLTHROUGH */ - case SAVEt_COMPPAD: - case SAVEt_NSTAB: - sv = (const SV *) POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_INT: /* int reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - intval = (int)POPINT(ss,ix); - TOPINT(nss,ix) = intval; - break; - case SAVEt_LONG: /* long reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - longval = (long)POPLONG(ss,ix); - TOPLONG(nss,ix) = longval; - break; - case SAVEt_I32: /* I32 reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_IV: /* IV reference */ - case SAVEt_STRLEN: /* STRLEN/size_t ref */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - break; - case SAVEt_TMPSFLOOR: - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - break; - case SAVEt_HPTR: /* HV* reference */ - case SAVEt_APTR: /* AV* reference */ - case SAVEt_SPTR: /* SV* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_VPTR: /* random* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - /* FALLTHROUGH */ - case SAVEt_STRLEN_SMALL: - case SAVEt_INT_SMALL: - case SAVEt_I32_SMALL: - case SAVEt_I16: /* I16 reference */ - case SAVEt_I8: /* I8 reference */ - case SAVEt_BOOL: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - break; - case SAVEt_GENERIC_PVREF: /* generic char* */ - case SAVEt_PPTR: /* char* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup(c); - break; - case SAVEt_GP: /* scalar reference */ - gp = (GP*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gp = gp_dup(gp, param); - (void)GpREFCNT_inc(gp); - gv = (const GV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv, param); - break; - case SAVEt_FREEOP: - ptr = POPPTR(ss,ix); - if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { - /* these are assumed to be refcounted properly */ - OP *o; - switch (((OP*)ptr)->op_type) { - case OP_LEAVESUB: - case OP_LEAVESUBLV: - case OP_LEAVEEVAL: - case OP_LEAVE: - case OP_SCOPE: - case OP_LEAVEWRITE: - TOPPTR(nss,ix) = ptr; - o = (OP*)ptr; - OP_REFCNT_LOCK; - (void) OpREFCNT_inc(o); - OP_REFCNT_UNLOCK; - break; - default: - TOPPTR(nss,ix) = NULL; - break; - } - } - else - TOPPTR(nss,ix) = NULL; - break; - case SAVEt_FREECOPHH: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); - break; - case SAVEt_ADELETE: - av = (const AV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av, param); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_DELETE: - hv = (const HV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - /* FALLTHROUGH */ - case SAVEt_FREEPV: - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup_inc(c); - break; - case SAVEt_STACK_POS: /* Position on Perl stack */ - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_DESTRUCTOR: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ - dptr = POPDPTR(ss,ix); - TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), - any_dup(FPTR2DPTR(void *, dptr), - proto_perl)); - break; - case SAVEt_DESTRUCTOR_X: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ - dxptr = POPDXPTR(ss,ix); - TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), - any_dup(FPTR2DPTR(void *, dxptr), - proto_perl)); - break; - case SAVEt_REGCONTEXT: - case SAVEt_ALLOC: - ix -= uv >> SAVE_TIGHT_SHIFT; - break; - case SAVEt_AELEM: /* array element */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - av = (const AV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av, param); - break; - case SAVEt_OP: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = ptr; - break; + sv = (const SV *) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* FALLTHROUGH */ + case SAVEt_COMPPAD: + case SAVEt_NSTAB: + sv = (const SV *) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + case SAVEt_STRLEN: /* STRLEN/size_t ref */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_TMPSFLOOR: + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_HPTR: /* HV* reference */ + case SAVEt_APTR: /* AV* reference */ + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* FALLTHROUGH */ + case SAVEt_STRLEN_SMALL: + case SAVEt_INT_SMALL: + case SAVEt_I32_SMALL: + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + case SAVEt_BOOL: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_GENERIC_PVREF: /* generic char* */ + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp, param); + (void)GpREFCNT_inc(gp); + gv = (const GV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + OP *o; + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = ptr; + o = (OP*)ptr; + OP_REFCNT_LOCK; + (void) OpREFCNT_inc(o); + OP_REFCNT_UNLOCK; + break; + default: + TOPPTR(nss,ix) = NULL; + break; + } + } + else + TOPPTR(nss,ix) = NULL; + break; + case SAVEt_FREECOPHH: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); + break; + case SAVEt_ADELETE: + av = (const AV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DELETE: + hv = (const HV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + /* FALLTHROUGH */ + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dptr = POPDPTR(ss,ix); + TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), + any_dup(FPTR2DPTR(void *, dptr), + proto_perl)); + break; + case SAVEt_DESTRUCTOR_X: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dxptr = POPDXPTR(ss,ix); + TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), + any_dup(FPTR2DPTR(void *, dxptr), + proto_perl)); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + ix -= uv >> SAVE_TIGHT_SHIFT; + break; + case SAVEt_AELEM: /* array element */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + av = (const AV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av, param); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; case SAVEt_HINTS_HH: hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); /* FALLTHROUGH */ - case SAVEt_HINTS: - ptr = POPPTR(ss,ix); - ptr = cophh_copy((COPHH*)ptr); - TOPPTR(nss,ix) = ptr; - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_PADSV_AND_MORTALIZE: - longval = (long)POPLONG(ss,ix); - TOPLONG(nss,ix) = longval; - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; - case SAVEt_SET_SVFLAGS: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_COMPILE_WARNINGS: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); - break; - case SAVEt_PARSER: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); - break; - default: - Perl_croak(aTHX_ - "panic: ss_dup inconsistency (%" IVdf ")", (IV) type); - } + case SAVEt_HINTS: + ptr = POPPTR(ss,ix); + ptr = cophh_copy((COPHH*)ptr); + TOPPTR(nss,ix) = ptr; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_PADSV_AND_MORTALIZE: + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; + case SAVEt_SET_SVFLAGS: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_COMPILE_WARNINGS: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); + break; + case SAVEt_PARSER: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); + break; + default: + Perl_croak(aTHX_ + "panic: ss_dup inconsistency (%" IVdf ")", (IV) type); + } } return nss; @@ -15037,26 +15037,26 @@ do_mark_cloneable_stash(pTHX_ SV *const sv) { const HEK * const hvname = HvNAME_HEK((const HV *)sv); if (hvname) { - GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); - SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ - if (cloner && GvCV(cloner)) { - dSP; - UV status; - - ENTER; - SAVETMPS; - PUSHMARK(SP); - mXPUSHs(newSVhek(hvname)); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); - SPAGAIN; - status = POPu; - PUTBACK; - FREETMPS; - LEAVE; - if (status) - SvFLAGS(sv) &= ~SVphv_CLONEABLE; - } + GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); + SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ + if (cloner && GvCV(cloner)) { + dSP; + UV status; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + mXPUSHs(newSVhek(hvname)); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); + SPAGAIN; + status = POPu; + PUTBACK; + FREETMPS; + LEAVE; + if (status) + SvFLAGS(sv) &= ~SVphv_CLONEABLE; + } } } @@ -15118,24 +15118,24 @@ perl_clone(PerlInterpreter *proto_perl, UV flags) } #endif return perl_clone_using(proto_perl, flags, - proto_perl->IMem, - proto_perl->IMemShared, - proto_perl->IMemParse, - proto_perl->IEnv, - proto_perl->IStdIO, - proto_perl->ILIO, - proto_perl->IDir, - proto_perl->ISock, - proto_perl->IProc); + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); } PerlInterpreter * perl_clone_using(PerlInterpreter *proto_perl, UV flags, - struct IPerlMem* ipM, struct IPerlMem* ipMS, - struct IPerlMem* ipMP, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { /* XXX many of the string copies here can be optimized if they're * constants; they need to be allocated as common memory and just @@ -15373,20 +15373,20 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); if (flags & CLONEf_COPY_STACKS) { - /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ - PL_tmps_ix = proto_perl->Itmps_ix; - PL_tmps_max = proto_perl->Itmps_max; - PL_tmps_floor = proto_perl->Itmps_floor; + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Itmps_ix; + PL_tmps_max = proto_perl->Itmps_max; + PL_tmps_floor = proto_perl->Itmps_floor; - /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] - * NOTE: unlike the others! */ - PL_scopestack_ix = proto_perl->Iscopestack_ix; - PL_scopestack_max = proto_perl->Iscopestack_max; + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Iscopestack_ix; + PL_scopestack_max = proto_perl->Iscopestack_max; - /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] - * NOTE: unlike the others! */ - PL_savestack_ix = proto_perl->Isavestack_ix; - PL_savestack_max = proto_perl->Isavestack_max; + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Isavestack_ix; + PL_savestack_max = proto_perl->Isavestack_max; } PL_start_env = proto_perl->Istart_env; /* XXXXXX */ @@ -15457,7 +15457,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Isv_zero, &PL_sv_zero); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const, - &PL_padname_const); + &PL_padname_const); /* create (a non-shared!) shared string table */ PL_strtab = newHV(); @@ -15486,7 +15486,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, AvREAL_off(param->stashes); if (!(flags & CLONEf_COPY_STACKS)) { - param->unreferenced = newAV(); + param->unreferenced = newAV(); } #ifdef PERLIO_LAYERS @@ -15526,9 +15526,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stashpadix = proto_perl->Istashpadix ; Newx(PL_stashpad, PL_stashpadmax, HV *); { - PADOFFSET o = 0; - for (; o < PL_stashpadmax; ++o) - PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); + PADOFFSET o = 0; + for (; o < PL_stashpadmax; ++o) + PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); } /* shortcuts to various I/O objects */ @@ -15578,9 +15578,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); if (proto_perl->Iop_mask) - PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); + PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); else - PL_op_mask = NULL; + PL_op_mask = NULL; /* PL_asserting = proto_perl->Iasserting; */ /* current interpreter roots */ @@ -15599,19 +15599,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* interpreter atexit processing */ PL_exitlistlen = proto_perl->Iexitlistlen; if (PL_exitlistlen) { - Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); - Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); } else - PL_exitlist = (PerlExitListEntry*)NULL; + PL_exitlist = (PerlExitListEntry*)NULL; PL_my_cxt_size = proto_perl->Imy_cxt_size; if (PL_my_cxt_size) { - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); } else { - PL_my_cxt_list = (void**)NULL; + PL_my_cxt_list = (void**)NULL; } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); @@ -15636,9 +15636,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* XXX this only works if the saved cop has already been cloned */ if (proto_perl->Iparser) { - PL_parser->saved_curcop = (COP*)any_dup( - proto_perl->Iparser->saved_curcop, - proto_perl); + PL_parser->saved_curcop = (COP*)any_dup( + proto_perl->Iparser->saved_curcop, + proto_perl); } PL_subname = sv_dup_inc(proto_perl->Isubname, param); @@ -15731,71 +15731,71 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif if (proto_perl->Ipsig_pend) { - Newxz(PL_psig_pend, SIG_SIZE, int); + Newxz(PL_psig_pend, SIG_SIZE, int); } else { - PL_psig_pend = (int*)NULL; + PL_psig_pend = (int*)NULL; } if (proto_perl->Ipsig_name) { - Newx(PL_psig_name, 2 * SIG_SIZE, SV*); - sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, - param); - PL_psig_ptr = PL_psig_name + SIG_SIZE; + Newx(PL_psig_name, 2 * SIG_SIZE, SV*); + sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, + param); + PL_psig_ptr = PL_psig_name + SIG_SIZE; } else { - PL_psig_ptr = (SV**)NULL; - PL_psig_name = (SV**)NULL; + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; } if (flags & CLONEf_COPY_STACKS) { - Newx(PL_tmps_stack, PL_tmps_max, SV*); - sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, - PL_tmps_ix+1, param); - - /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; - Newx(PL_markstack, i, I32); - PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max - - proto_perl->Imarkstack); - PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr - - proto_perl->Imarkstack); - Copy(proto_perl->Imarkstack, PL_markstack, - PL_markstack_ptr - PL_markstack + 1, I32); - - /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] - * NOTE: unlike the others! */ - Newx(PL_scopestack, PL_scopestack_max, I32); - Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); + Newx(PL_tmps_stack, PL_tmps_max, SV*); + sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, + PL_tmps_ix+1, param); + + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; + Newx(PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max + - proto_perl->Imarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr + - proto_perl->Imarkstack); + Copy(proto_perl->Imarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + Newx(PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); #ifdef DEBUGGING - Newx(PL_scopestack_name, PL_scopestack_max, const char *); - Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); + Newx(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); #endif /* reset stack AV to correct length before its duped via * PL_curstackinfo */ AvFILLp(proto_perl->Icurstack) = proto_perl->Istack_sp - proto_perl->Istack_base; - /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); - /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Icurstack, param); - PL_mainstack = av_dup(proto_perl->Imainstack, param); + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Icurstack, param); + PL_mainstack = av_dup(proto_perl->Imainstack, param); - /* next PUSHs() etc. set *(PL_stack_sp+1) */ - PL_stack_base = AvARRAY(PL_curstack); - PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp - - proto_perl->Istack_base); - PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp + - proto_perl->Istack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = ss_dup(proto_perl, param); + /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl, param); } else { - init_stacks(); - ENTER; /* perl_destruct() wants to LEAVE; */ + init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ } PL_statgv = gv_dup(proto_perl->Istatgv, param); @@ -15817,13 +15817,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stashcache = newHV(); PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, - proto_perl->Iwatchaddr); + proto_perl->Iwatchaddr); PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; if (PL_debug && PL_watchaddr) { - PerlIO_printf(Perl_debug_log, - "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n", - PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), - PTR2UV(PL_watchok)); + PerlIO_printf(Perl_debug_log, + "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n", + PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), + PTR2UV(PL_watchok)); } PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); @@ -15833,19 +15833,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, identified by sv_dup() above. */ while(av_count(param->stashes) != 0) { - HV* const stash = MUTABLE_HV(av_shift(param->stashes)); - GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); - if (cloner && GvCV(cloner)) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - mXPUSHs(newSVhek(HvNAME_HEK(stash))); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); - FREETMPS; - LEAVE; - } + HV* const stash = MUTABLE_HV(av_shift(param->stashes)); + GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); + if (cloner && GvCV(cloner)) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + mXPUSHs(newSVhek(HvNAME_HEK(stash))); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); + FREETMPS; + LEAVE; + } } if (!(flags & CLONEf_KEEP_PTR_TABLE)) { @@ -15854,15 +15854,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } if (!(flags & CLONEf_COPY_STACKS)) { - unreferenced_to_tmp_stack(param->unreferenced); + unreferenced_to_tmp_stack(param->unreferenced); } SvREFCNT_dec(param->stashes); /* orphaned? eg threads->new inside BEGIN or use */ if (PL_compcv && ! SvREFCNT(PL_compcv)) { - SvREFCNT_inc_simple_void(PL_compcv); - SAVEFREESV(PL_compcv); + SvREFCNT_inc_simple_void(PL_compcv); + SAVEFREESV(PL_compcv); } return my_perl; @@ -15874,40 +15874,40 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; if (AvFILLp(unreferenced) > -1) { - SV **svp = AvARRAY(unreferenced); - SV **const last = svp + AvFILLp(unreferenced); - SSize_t count = 0; - - do { - if (SvREFCNT(*svp) == 1) - ++count; - } while (++svp <= last); - - EXTEND_MORTAL(count); - svp = AvARRAY(unreferenced); - - do { - if (SvREFCNT(*svp) == 1) { - /* Our reference is the only one to this SV. This means that - in this thread, the scalar effectively has a 0 reference. - That doesn't work (cleanup never happens), so donate our - reference to it onto the save stack. */ - PL_tmps_stack[++PL_tmps_ix] = *svp; - } else { - /* As an optimisation, because we are already walking the - entire array, instead of above doing either - SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead - release our reference to the scalar, so that at the end of - the array owns zero references to the scalars it happens to - point to. We are effectively converting the array from - AvREAL() on to AvREAL() off. This saves the av_clear() - (triggered by the SvREFCNT_dec(unreferenced) below) from - walking the array a second time. */ - SvREFCNT_dec(*svp); - } - - } while (++svp <= last); - AvREAL_off(unreferenced); + SV **svp = AvARRAY(unreferenced); + SV **const last = svp + AvFILLp(unreferenced); + SSize_t count = 0; + + do { + if (SvREFCNT(*svp) == 1) + ++count; + } while (++svp <= last); + + EXTEND_MORTAL(count); + svp = AvARRAY(unreferenced); + + do { + if (SvREFCNT(*svp) == 1) { + /* Our reference is the only one to this SV. This means that + in this thread, the scalar effectively has a 0 reference. + That doesn't work (cleanup never happens), so donate our + reference to it onto the save stack. */ + PL_tmps_stack[++PL_tmps_ix] = *svp; + } else { + /* As an optimisation, because we are already walking the + entire array, instead of above doing either + SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead + release our reference to the scalar, so that at the end of + the array owns zero references to the scalars it happens to + point to. We are effectively converting the array from + AvREAL() on to AvREAL() off. This saves the av_clear() + (triggered by the SvREFCNT_dec(unreferenced) below) from + walking the array a second time. */ + SvREFCNT_dec(*svp); + } + + } while (++svp <= last); + AvREAL_off(unreferenced); } SvREFCNT_dec_NN(unreferenced); } @@ -15922,17 +15922,17 @@ Perl_clone_params_del(CLONE_PARAMS *param) PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; if (was != to) { - PERL_SET_THX(to); + PERL_SET_THX(to); } SvREFCNT_dec(param->stashes); if (param->unreferenced) - unreferenced_to_tmp_stack(param->unreferenced); + unreferenced_to_tmp_stack(param->unreferenced); Safefree(param); if (was != to) { - PERL_SET_THX(was); + PERL_SET_THX(was); } } @@ -15949,7 +15949,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; if (was != to) { - PERL_SET_THX(to); + PERL_SET_THX(to); } /* Given that we've set the context, we can do this unshared. */ @@ -15963,7 +15963,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); if (was != to) { - PERL_SET_THX(was); + PERL_SET_THX(was); } return param; } @@ -15981,20 +15981,20 @@ Perl_init_constants(pTHX) SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; SvANY(&PL_sv_zero) = new_XPVNV(); SvREFCNT(&PL_sv_zero) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_zero) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK |SVs_PADTMP; SvPV_set(&PL_sv_no, (char*)PL_No); @@ -16062,23 +16062,23 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { - SV *uni; - STRLEN len; - const char *s; - dSP; - SV *nsv = sv; - ENTER; - PUSHSTACK; - SAVETMPS; - if (SvPADTMP(nsv)) { - nsv = sv_newmortal(); - SvSetSV_nosteal(nsv, sv); - } - save_re_context(); - PUSHMARK(sp); - EXTEND(SP, 3); - PUSHs(encoding); - PUSHs(nsv); + SV *uni; + STRLEN len; + const char *s; + dSP; + SV *nsv = sv; + ENTER; + PUSHSTACK; + SAVETMPS; + if (SvPADTMP(nsv)) { + nsv = sv_newmortal(); + SvSetSV_nosteal(nsv, sv); + } + save_re_context(); + PUSHMARK(sp); + EXTEND(SP, 3); + PUSHs(encoding); + PUSHs(nsv); /* NI-S 2002/07/09 Passing sv_yes is wrong - it needs to be or'ed set of constants @@ -16087,32 +16087,32 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) Both will default the value - let them. - XPUSHs(&PL_sv_yes); + XPUSHs(&PL_sv_yes); */ - PUTBACK; - call_method("decode", G_SCALAR); - SPAGAIN; - uni = POPs; - PUTBACK; - s = SvPV_const(uni, len); - if (s != SvPVX_const(sv)) { - SvGROW(sv, len + 1); - Move(s, SvPVX(sv), len + 1, char); - SvCUR_set(sv, len); - } - FREETMPS; - POPSTACK; - LEAVE; - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* clear pos and any utf8 cache */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) - mg->mg_len = -1; - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } - SvUTF8_on(sv); - return SvPVX(sv); + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV_const(uni, len); + if (s != SvPVX_const(sv)) { + SvGROW(sv, len + 1); + Move(s, SvPVX(sv), len + 1, char); + SvCUR_set(sv, len); + } + FREETMPS; + POPSTACK; + LEAVE; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* clear pos and any utf8 cache */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) + mg->mg_len = -1; + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } + SvUTF8_on(sv); + return SvPVX(sv); } return SvPOKp(sv) ? SvPVX(sv) : NULL; } @@ -16134,34 +16134,34 @@ Returns TRUE if the terminator was found, else returns FALSE. bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, - SV *ssv, int *offset, char *tstr, int tlen) + SV *ssv, int *offset, char *tstr, int tlen) { bool ret = FALSE; PERL_ARGS_ASSERT_SV_CAT_DECODE; if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) { - SV *offsv; - dSP; - ENTER; - SAVETMPS; - save_re_context(); - PUSHMARK(sp); - EXTEND(SP, 6); - PUSHs(encoding); - PUSHs(dsv); - PUSHs(ssv); - offsv = newSViv(*offset); - mPUSHs(offsv); - mPUSHp(tstr, tlen); - PUTBACK; - call_method("cat_decode", G_SCALAR); - SPAGAIN; - ret = SvTRUE(TOPs); - *offset = SvIV(offsv); - PUTBACK; - FREETMPS; - LEAVE; + SV *offsv; + dSP; + ENTER; + SAVETMPS; + save_re_context(); + PUSHMARK(sp); + EXTEND(SP, 6); + PUSHs(encoding); + PUSHs(dsv); + PUSHs(ssv); + offsv = newSViv(*offset); + mPUSHs(offsv); + mPUSHp(tstr, tlen); + PUTBACK; + call_method("cat_decode", G_SCALAR); + SPAGAIN; + ret = SvTRUE(TOPs); + *offset = SvIV(offsv); + PUTBACK; + FREETMPS; + LEAVE; } else Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); @@ -16191,25 +16191,25 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || - (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) - return NULL; + (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) + return NULL; array = HvARRAY(hv); for (i=HvMAX(hv); i>=0; i--) { - HE *entry; - for (entry = array[i]; entry; entry = HeNEXT(entry)) { - if (HeVAL(entry) != val) - continue; - if ( HeVAL(entry) == &PL_sv_undef || - HeVAL(entry) == &PL_sv_placeholder) - continue; - if (!HeKEY(entry)) - return NULL; - if (HeKLEN(entry) == HEf_SVKEY) - return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVhek(HeKEY_hek(entry))); - } + HE *entry; + for (entry = array[i]; entry; entry = HeNEXT(entry)) { + if (HeVAL(entry) != val) + continue; + if ( HeVAL(entry) == &PL_sv_undef || + HeVAL(entry) == &PL_sv_placeholder) + continue; + if (!HeKEY(entry)) + return NULL; + if (HeKLEN(entry) == HEf_SVKEY) + return sv_mortalcopy(HeKEY_sv(entry)); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); + } } return NULL; } @@ -16223,16 +16223,16 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; if (!av || SvMAGICAL(av) || !AvARRAY(av) || - (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) - return -1; + (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) + return -1; if (val != &PL_sv_undef) { - SV ** const svp = AvARRAY(av); - SSize_t i; + SV ** const svp = AvARRAY(av); + SSize_t i; - for (i=AvFILLp(av); i>=0; i--) - if (svp[i] == val) - return i; + for (i=AvFILLp(av); i>=0; i--) + if (svp[i] == val) + return i; } return -1; } @@ -16250,59 +16250,59 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) SV* Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, - const SV *const keyname, SSize_t aindex, int subscript_type) + const SV *const keyname, SSize_t aindex, int subscript_type) { SV * const name = sv_newmortal(); if (gv && isGV(gv)) { - char buffer[2]; - buffer[0] = gvtype; - buffer[1] = 0; + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; - /* as gv_fullname4(), but add literal '^' for $^FOO names */ + /* as gv_fullname4(), but add literal '^' for $^FOO names */ - gv_fullname4(name, gv, buffer, 0); + gv_fullname4(name, gv, buffer, 0); - if ((unsigned int)SvPVX(name)[1] <= 26) { - buffer[0] = '^'; - buffer[1] = SvPVX(name)[1] + 'A' - 1; + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; - /* Swap the 1 unprintable control character for the 2 byte pretty - version - ie substr($name, 1, 1) = $buffer; */ - sv_insert(name, 1, 1, buffer, 2); - } + /* Swap the 1 unprintable control character for the 2 byte pretty + version - ie substr($name, 1, 1) = $buffer; */ + sv_insert(name, 1, 1, buffer, 2); + } } else { - CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); - PADNAME *sv; + CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); + PADNAME *sv; - assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); + assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); - if (!cv || !CvPADLIST(cv)) - return NULL; - sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ); - sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv)); - SvUTF8_on(name); + if (!cv || !CvPADLIST(cv)) + return NULL; + sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ); + sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv)); + SvUTF8_on(name); } if (subscript_type == FUV_SUBSCRIPT_HASH) { - SV * const sv = newSV(0); + SV * const sv = newSV(0); STRLEN len; const char * const pv = SvPV_nomg_const((SV*)keyname, len); - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_pretty(sv, pv, len, 32, NULL, NULL, - PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); - SvREFCNT_dec_NN(sv); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "{%s}", + pv_pretty(sv, pv, len, 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); + SvREFCNT_dec_NN(sv); } else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex); } else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { - /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ - Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); + /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ + Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); } return name; @@ -16334,7 +16334,7 @@ C/C points to the currently executing pad. STATIC SV * S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, - bool match, const char **desc_p) + bool match, const char **desc_p) { SV *sv; const GV *gv; @@ -16343,8 +16343,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, PERL_ARGS_ASSERT_FIND_UNINIT_VAR; if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || - uninit_sv == &PL_sv_placeholder))) - return NULL; + uninit_sv == &PL_sv_placeholder))) + return NULL; switch (obase->op_type) { @@ -16358,216 +16358,216 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_PADAV: case OP_PADHV: { - const bool pad = ( obase->op_type == OP_PADAV + const bool pad = ( obase->op_type == OP_PADAV || obase->op_type == OP_PADHV || obase->op_type == OP_PADRANGE ); - const bool hash = ( obase->op_type == OP_PADHV + const bool hash = ( obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV || (obase->op_type == OP_PADRANGE && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV) ); - SSize_t index = 0; - SV *keysv = NULL; - int subscript_type = FUV_SUBSCRIPT_WITHIN; - - if (pad) { /* @lex, %lex */ - sv = PAD_SVl(obase->op_targ); - gv = NULL; - } - else { - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* @global, %global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv) - break; - sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); - } - else if (obase == PL_op) /* @{expr}, %{expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, + SSize_t index = 0; + SV *keysv = NULL; + int subscript_type = FUV_SUBSCRIPT_WITHIN; + + if (pad) { /* @lex, %lex */ + sv = PAD_SVl(obase->op_targ); + gv = NULL; + } + else { + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* @global, %global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv) + break; + sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); + } + else if (obase == PL_op) /* @{expr}, %{expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, match, desc_p); - else /* @{expr}, %{expr} as a sub-expression */ - return NULL; - } - - /* attempt to find a match within the aggregate */ - if (hash) { - keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - subscript_type = FUV_SUBSCRIPT_HASH; - } - else { - index = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - subscript_type = FUV_SUBSCRIPT_ARRAY; - } - - if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) - break; - - return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ, - keysv, index, subscript_type); + else /* @{expr}, %{expr} as a sub-expression */ + return NULL; + } + + /* attempt to find a match within the aggregate */ + if (hash) { + keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + subscript_type = FUV_SUBSCRIPT_HASH; + } + else { + index = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + subscript_type = FUV_SUBSCRIPT_ARRAY; + } + + if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) + break; + + return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ, + keysv, index, subscript_type); } case OP_RV2SV: - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* $global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv || !GvSTASH(gv)) - break; - if (match && (GvSV(gv) != uninit_sv)) - break; - return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); - } - /* ${expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p); + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* $global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv || !GvSTASH(gv)) + break; + if (match && (GvSV(gv) != uninit_sv)) + break; + return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); + } + /* ${expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p); case OP_PADSV: - if (match && PAD_SVl(obase->op_targ) != uninit_sv) - break; - return varname(NULL, '$', obase->op_targ, - NULL, 0, FUV_SUBSCRIPT_NONE); + if (match && PAD_SVl(obase->op_targ) != uninit_sv) + break; + return varname(NULL, '$', obase->op_targ, + NULL, 0, FUV_SUBSCRIPT_NONE); case OP_GVSV: - gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) - break; - return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); + gv = cGVOPx_gv(obase); + if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) + break; + return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); case OP_AELEMFAST_LEX: - if (match) { - SV **svp; - AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I8)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(NULL, '$', obase->op_targ, - NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); + if (match) { + SV **svp; + AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I8)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(NULL, '$', obase->op_targ, + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); case OP_AELEMFAST: - { - gv = cGVOPx_gv(obase); - if (!gv) - break; - if (match) { - SV **svp; - AV *const av = GvAV(gv); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I8)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(gv, '$', 0, - NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - NOT_REACHED; /* NOTREACHED */ + { + gv = cGVOPx_gv(obase); + if (!gv) + break; + if (match) { + SV **svp; + AV *const av = GvAV(gv); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I8)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(gv, '$', 0, + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + NOT_REACHED; /* NOTREACHED */ case OP_EXISTS: - o = cUNOPx(obase)->op_first; - if (!o || o->op_type != OP_NULL || - ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) - break; - return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p); + o = cUNOPx(obase)->op_first; + if (!o || o->op_type != OP_NULL || + ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) + break; + return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p); case OP_AELEM: case OP_HELEM: { - bool negate = FALSE; + bool negate = FALSE; - if (PL_op == obase) - /* $a[uninit_expr] or $h{uninit_expr} */ - return find_uninit_var(cBINOPx(obase)->op_last, + if (PL_op == obase) + /* $a[uninit_expr] or $h{uninit_expr} */ + return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match, desc_p); - gv = NULL; - o = cBINOPx(obase)->op_first; - kid = cBINOPx(obase)->op_last; - - /* get the av or hv, and optionally the gv */ - sv = NULL; - if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { - sv = PAD_SV(o->op_targ); - } - else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) - && cUNOPo->op_first->op_type == OP_GV) - { - gv = cGVOPx_gv(cUNOPo->op_first); - if (!gv) - break; - sv = o->op_type - == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); - } - if (!sv) - break; - - if (kid && kid->op_type == OP_NEGATE) { - negate = TRUE; - kid = cUNOPx(kid)->op_first; - } - - if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { - /* index is constant */ - SV* kidsv; - if (negate) { - kidsv = newSVpvs_flags("-", SVs_TEMP); - sv_catsv(kidsv, cSVOPx_sv(kid)); - } - else - kidsv = cSVOPx_sv(kid); - if (match) { - if (SvMAGICAL(sv)) - break; - if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV * const opsv = cSVOPx_sv(kid); - const IV opsviv = SvIV(opsv); - SV * const * const svp = av_fetch(MUTABLE_AV(sv), - negate ? - opsviv : opsviv, - FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - if (obase->op_type == OP_HELEM) - return varname(gv, '%', o->op_targ, - kidsv, 0, FUV_SUBSCRIPT_HASH); - else - return varname(gv, '@', o->op_targ, NULL, - negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), - FUV_SUBSCRIPT_ARRAY); - } - else { - /* index is an expression; - * attempt to find a match within the aggregate */ - if (obase->op_type == OP_HELEM) { - SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - return varname(gv, '%', o->op_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const SSize_t index - = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - return varname(gv, '@', o->op_targ, - NULL, index, FUV_SUBSCRIPT_ARRAY); - } - if (match) - break; - return varname(gv, - (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV) - ? '@' : '%'), - o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); - } - NOT_REACHED; /* NOTREACHED */ + gv = NULL; + o = cBINOPx(obase)->op_first; + kid = cBINOPx(obase)->op_last; + + /* get the av or hv, and optionally the gv */ + sv = NULL; + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { + sv = PAD_SV(o->op_targ); + } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) + && cUNOPo->op_first->op_type == OP_GV) + { + gv = cGVOPx_gv(cUNOPo->op_first); + if (!gv) + break; + sv = o->op_type + == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); + } + if (!sv) + break; + + if (kid && kid->op_type == OP_NEGATE) { + negate = TRUE; + kid = cUNOPx(kid)->op_first; + } + + if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { + /* index is constant */ + SV* kidsv; + if (negate) { + kidsv = newSVpvs_flags("-", SVs_TEMP); + sv_catsv(kidsv, cSVOPx_sv(kid)); + } + else + kidsv = cSVOPx_sv(kid); + if (match) { + if (SvMAGICAL(sv)) + break; + if (obase->op_type == OP_HELEM) { + HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV * const opsv = cSVOPx_sv(kid); + const IV opsviv = SvIV(opsv); + SV * const * const svp = av_fetch(MUTABLE_AV(sv), + negate ? - opsviv : opsviv, + FALSE); + if (!svp || *svp != uninit_sv) + break; + } + } + if (obase->op_type == OP_HELEM) + return varname(gv, '%', o->op_targ, + kidsv, 0, FUV_SUBSCRIPT_HASH); + else + return varname(gv, '@', o->op_targ, NULL, + negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), + FUV_SUBSCRIPT_ARRAY); + } + else { + /* index is an expression; + * attempt to find a match within the aggregate */ + if (obase->op_type == OP_HELEM) { + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + return varname(gv, '%', o->op_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const SSize_t index + = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + return varname(gv, '@', o->op_targ, + NULL, index, FUV_SUBSCRIPT_ARRAY); + } + if (match) + break; + return varname(gv, + (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV) + ? '@' : '%'), + o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); + } + NOT_REACHED; /* NOTREACHED */ } case OP_MULTIDEREF: { @@ -16688,8 +16688,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, actions >>= MDEREF_SHIFT; } /* while */ - if (PL_op == obase) { - /* most likely index was undef */ + if (PL_op == obase) { + /* most likely index was undef */ *desc_p = ( (actions & MDEREF_FLAG_last) && (obase->op_private @@ -16710,7 +16710,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if (index_targ) { if (PL_curpad[index_targ] == uninit_sv) return varname(NULL, '$', index_targ, - NULL, 0, FUV_SUBSCRIPT_NONE); + NULL, 0, FUV_SUBSCRIPT_NONE); else return NULL; } @@ -16725,7 +16725,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, break; if (agg_targ) - sv = PAD_SV(agg_targ); + sv = PAD_SV(agg_targ); else if (agg_gv) { sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv)); if (!sv) @@ -16734,43 +16734,43 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, else break; - if (index_type == MDEREF_INDEX_const) { - if (match) { - if (SvMAGICAL(sv)) - break; - if (is_hv) { - HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV * const * const svp = + if (index_type == MDEREF_INDEX_const) { + if (match) { + if (SvMAGICAL(sv)) + break; + if (is_hv) { + HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV * const * const svp = av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - return is_hv - ? varname(agg_gv, '%', agg_targ, + if (!svp || *svp != uninit_sv) + break; + } + } + return is_hv + ? varname(agg_gv, '%', agg_targ, index_const_sv, 0, FUV_SUBSCRIPT_HASH) - : varname(agg_gv, '@', agg_targ, + : varname(agg_gv, '@', agg_targ, NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY); - } - else { - /* index is an var */ - if (is_hv) { - SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - return varname(agg_gv, '%', agg_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const SSize_t index - = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - return varname(agg_gv, '@', agg_targ, - NULL, index, FUV_SUBSCRIPT_ARRAY); - } + } + else { + /* index is an var */ + if (is_hv) { + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + return varname(agg_gv, '%', agg_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const SSize_t index + = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + return varname(agg_gv, '@', agg_targ, + NULL, index, FUV_SUBSCRIPT_ARRAY); + } /* look for an element not found */ if (!SvMAGICAL(sv)) { SV *index_sv = NULL; @@ -16799,80 +16799,80 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, } } } - if (match) - break; - return varname(agg_gv, - is_hv ? '%' : '@', - agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); - } - NOT_REACHED; /* NOTREACHED */ + if (match) + break; + return varname(agg_gv, + is_hv ? '%' : '@', + agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); + } + NOT_REACHED; /* NOTREACHED */ } case OP_AASSIGN: - /* only examine RHS */ - return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, + /* only examine RHS */ + return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match, desc_p); case OP_OPEN: - o = cUNOPx(obase)->op_first; - if ( o->op_type == OP_PUSHMARK - || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) + o = cUNOPx(obase)->op_first; + if ( o->op_type == OP_PUSHMARK + || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) ) o = OpSIBLING(o); - if (!OpHAS_SIBLING(o)) { - /* one-arg version of open is highly magical */ - - if (o->op_type == OP_GV) { /* open FOO; */ - gv = cGVOPx_gv(o); - if (match && GvSV(gv) != uninit_sv) - break; - return varname(gv, '$', 0, - NULL, 0, FUV_SUBSCRIPT_NONE); - } - /* other possibilities not handled are: - * open $x; or open my $x; should return '${*$x}' - * open expr; should return '$'.expr ideally - */ - break; - } - match = 1; - goto do_op; + if (!OpHAS_SIBLING(o)) { + /* one-arg version of open is highly magical */ + + if (o->op_type == OP_GV) { /* open FOO; */ + gv = cGVOPx_gv(o); + if (match && GvSV(gv) != uninit_sv) + break; + return varname(gv, '$', 0, + NULL, 0, FUV_SUBSCRIPT_NONE); + } + /* other possibilities not handled are: + * open $x; or open my $x; should return '${*$x}' + * open expr; should return '$'.expr ideally + */ + break; + } + match = 1; + goto do_op; /* ops where $_ may be an implicit arg */ case OP_TRANS: case OP_TRANSR: case OP_SUBST: case OP_MATCH: - if ( !(obase->op_flags & OPf_STACKED)) { - if (uninit_sv == DEFSV) - return newSVpvs_flags("$_", SVs_TEMP); - else if (obase->op_targ - && uninit_sv == PAD_SVl(obase->op_targ)) - return varname(NULL, '$', obase->op_targ, NULL, 0, - FUV_SUBSCRIPT_NONE); - } - goto do_op; + if ( !(obase->op_flags & OPf_STACKED)) { + if (uninit_sv == DEFSV) + return newSVpvs_flags("$_", SVs_TEMP); + else if (obase->op_targ + && uninit_sv == PAD_SVl(obase->op_targ)) + return varname(NULL, '$', obase->op_targ, NULL, 0, + FUV_SUBSCRIPT_NONE); + } + goto do_op; case OP_PRTF: case OP_PRINT: case OP_SAY: - match = 1; /* print etc can return undef on defined args */ - /* skip filehandle as it can't produce 'undef' warning */ - o = cUNOPx(obase)->op_first; - if ((obase->op_flags & OPf_STACKED) + match = 1; /* print etc can return undef on defined args */ + /* skip filehandle as it can't produce 'undef' warning */ + o = cUNOPx(obase)->op_first; + if ((obase->op_flags & OPf_STACKED) && ( o->op_type == OP_PUSHMARK || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) o = OpSIBLING(OpSIBLING(o)); - goto do_op2; + goto do_op2; case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ case OP_CUSTOM: /* XS or custom code could trigger random warnings */ - /* the following ops are capable of returning PL_sv_undef even for - * defined arg(s) */ + /* the following ops are capable of returning PL_sv_undef even for + * defined arg(s) */ case OP_BACKTICK: case OP_PIPE_OP: @@ -16942,85 +16942,85 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_UNPACK: case OP_SYSOPEN: case OP_SYSSEEK: - match = 1; - goto do_op; + match = 1; + goto do_op; case OP_ENTERSUB: case OP_GOTO: - /* XXX tmp hack: these two may call an XS sub, and currently - XS subs don't have a SUB entry on the context stack, so CV and - pad determination goes wrong, and BAD things happen. So, just - don't try to determine the value under those circumstances. - Need a better fix at dome point. DAPM 11/2007 */ - break; + /* XXX tmp hack: these two may call an XS sub, and currently + XS subs don't have a SUB entry on the context stack, so CV and + pad determination goes wrong, and BAD things happen. So, just + don't try to determine the value under those circumstances. + Need a better fix at dome point. DAPM 11/2007 */ + break; case OP_FLIP: case OP_FLOP: { - GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); - if (gv && GvSV(gv) == uninit_sv) - return newSVpvs_flags("$.", SVs_TEMP); - goto do_op; + GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv) == uninit_sv) + return newSVpvs_flags("$.", SVs_TEMP); + goto do_op; } case OP_POS: - /* def-ness of rval pos() is independent of the def-ness of its arg */ - if ( !(obase->op_flags & OPf_MOD)) - break; + /* def-ness of rval pos() is independent of the def-ness of its arg */ + if ( !(obase->op_flags & OPf_MOD)) + break; /* FALLTHROUGH */ case OP_SCHOMP: case OP_CHOMP: - if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return newSVpvs_flags("${$/}", SVs_TEMP); - /* FALLTHROUGH */ + if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) + return newSVpvs_flags("${$/}", SVs_TEMP); + /* FALLTHROUGH */ default: do_op: - if (!(obase->op_flags & OPf_KIDS)) - break; - o = cUNOPx(obase)->op_first; + if (!(obase->op_flags & OPf_KIDS)) + break; + o = cUNOPx(obase)->op_first; do_op2: - if (!o) - break; - - /* This loop checks all the kid ops, skipping any that cannot pos- - * sibly be responsible for the uninitialized value; i.e., defined - * constants and ops that return nothing. If there is only one op - * left that is not skipped, then we *know* it is responsible for - * the uninitialized value. If there is more than one op left, we - * have to look for an exact match in the while() loop below. + if (!o) + break; + + /* This loop checks all the kid ops, skipping any that cannot pos- + * sibly be responsible for the uninitialized value; i.e., defined + * constants and ops that return nothing. If there is only one op + * left that is not skipped, then we *know* it is responsible for + * the uninitialized value. If there is more than one op left, we + * have to look for an exact match in the while() loop below. * Note that we skip padrange, because the individual pad ops that * it replaced are still in the tree, so we work on them instead. - */ - o2 = NULL; - for (kid=o; kid; kid = OpSIBLING(kid)) { - const OPCODE type = kid->op_type; - if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (type == OP_PUSHMARK) - || (type == OP_PADRANGE) - ) - continue; - - if (o2) { /* more than one found */ - o2 = NULL; - break; - } - o2 = kid; - } - if (o2) - return find_uninit_var(o2, uninit_sv, match, desc_p); - - /* scan all args */ - while (o) { - sv = find_uninit_var(o, uninit_sv, 1, desc_p); - if (sv) - return sv; - o = OpSIBLING(o); - } - break; + */ + o2 = NULL; + for (kid=o; kid; kid = OpSIBLING(kid)) { + const OPCODE type = kid->op_type; + if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (type == OP_PUSHMARK) + || (type == OP_PADRANGE) + ) + continue; + + if (o2) { /* more than one found */ + o2 = NULL; + break; + } + o2 = kid; + } + if (o2) + return find_uninit_var(o2, uninit_sv, match, desc_p); + + /* scan all args */ + while (o) { + sv = find_uninit_var(o, uninit_sv, 1, desc_p); + if (sv) + return sv; + o = OpSIBLING(o); + } + break; } return NULL; } @@ -17041,17 +17041,17 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) SV* varname = NULL; if (PL_op) { - desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded - ? "join or string" + desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded + ? "join or string" : PL_op->op_type == OP_MULTICONCAT && (PL_op->op_private & OPpMULTICONCAT_FAKE) ? "sprintf" - : OP_DESC(PL_op); - if (uninit_sv && PL_curpad) { - varname = find_uninit_var(PL_op, uninit_sv, 0, &desc); - if (varname) - sv_insert(varname, 0, 0, " ", 1); - } + : OP_DESC(PL_op); + if (uninit_sv && PL_curpad) { + varname = find_uninit_var(PL_op, uninit_sv, 0, &desc); + if (varname) + sv_insert(varname, 0, 0, " ", 1); + } } else if (PL_curstackinfo->si_type == PERLSI_SORT && cxstack_ix == 0) /* we've reached the end of a sort block or sub, diff --git a/sv.h b/sv.h index 240986ca33cf..6a4ad86fb533 100644 --- a/sv.h +++ b/sv.h @@ -130,29 +130,29 @@ Type flag for I/O objects. See L. typedef enum { - SVt_NULL, /* 0 */ - /* BIND was here, before INVLIST replaced it. */ - SVt_IV, /* 1 */ - SVt_NV, /* 2 */ - /* RV was here, before it was merged with IV. */ - SVt_PV, /* 3 */ - SVt_INVLIST, /* 4, implemented as a PV */ - SVt_PVIV, /* 5 */ - SVt_PVNV, /* 6 */ - SVt_PVMG, /* 7 */ - SVt_REGEXP, /* 8 */ - /* PVBM was here, before BIND replaced it. */ - SVt_PVGV, /* 9 */ - SVt_PVLV, /* 10 */ - SVt_PVAV, /* 11 */ - SVt_PVHV, /* 12 */ - SVt_PVCV, /* 13 */ - SVt_PVFM, /* 14 */ - SVt_PVIO, /* 15 */ + SVt_NULL, /* 0 */ + /* BIND was here, before INVLIST replaced it. */ + SVt_IV, /* 1 */ + SVt_NV, /* 2 */ + /* RV was here, before it was merged with IV. */ + SVt_PV, /* 3 */ + SVt_INVLIST, /* 4, implemented as a PV */ + SVt_PVIV, /* 5 */ + SVt_PVNV, /* 6 */ + SVt_PVMG, /* 7 */ + SVt_REGEXP, /* 8 */ + /* PVBM was here, before BIND replaced it. */ + SVt_PVGV, /* 9 */ + SVt_PVLV, /* 10 */ + SVt_PVAV, /* 11 */ + SVt_PVHV, /* 12 */ + SVt_PVCV, /* 13 */ + SVt_PVFM, /* 14 */ + SVt_PVIO, /* 15 */ /* 16-31: Unused, though one should be reserved for a * freed sv, if the other 3 bits below the flags ones * get allocated */ - SVt_LAST /* keep last in enum. used to size arrays */ + SVt_LAST /* keep last in enum. used to size arrays */ } svtype; /* *** any alterations to the SV types above need to be reflected in @@ -206,15 +206,15 @@ typedef struct hek HEK; #define _SV_HEAD_UNION \ union { \ - char* svu_pv; /* pointer to malloced string */ \ - IV svu_iv; \ - UV svu_uv; \ - _NV_BODYLESS_UNION \ - SV* svu_rv; /* pointer to another SV */ \ - SV** svu_array; \ - HE** svu_hash; \ - GP* svu_gp; \ - PerlIO *svu_fp; \ + char* svu_pv; /* pointer to malloced string */ \ + IV svu_iv; \ + UV svu_uv; \ + _NV_BODYLESS_UNION \ + SV* svu_rv; /* pointer to another SV */ \ + SV** svu_array; \ + HE** svu_hash; \ + GP* svu_gp; \ + PerlIO *svu_fp; \ } sv_u \ _SV_HEAD_DEBUG @@ -379,9 +379,9 @@ perform the upgrade if necessary. See C>. #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 - subroutine in another package. Set the - GvIMPORTED_CV_on() if it needs to be - expanded to a real GV */ + subroutine in another package. Set the + GvIMPORTED_CV_on() if it needs to be + expanded to a real GV */ /* SVf_PROTECT is what SVf_READONLY should have been: i.e. modifying * this SV is completely illegal. However, SVf_READONLY (via @@ -394,7 +394,7 @@ perform the upgrade if necessary. See C>. #define SVf_PROTECT 0x00010000 /* very read-only */ #define SVs_PADTMP 0x00020000 /* in use as tmp */ #define SVs_PADSTALE 0x00040000 /* lexical has gone out of scope; - only used when !PADTMP */ + only used when !PADTMP */ #define SVs_TEMP 0x00080000 /* mortal (implies string is stealable) */ #define SVs_OBJECT 0x00100000 /* is "blessed" */ #define SVs_GMG 0x00200000 /* has magical get method */ @@ -402,10 +402,10 @@ perform the upgrade if necessary. See C>. #define SVs_RMG 0x00800000 /* has random magical methods */ #define SVf_FAKE 0x01000000 /* 0: glob is just a copy - 1: SV head arena wasn't malloc()ed - 2: For PVCV, whether CvUNIQUE(cv) - refers to an eval or once only - [CvEVAL(cv), CvSPECIAL(cv)] + 1: SV head arena wasn't malloc()ed + 2: For PVCV, whether CvUNIQUE(cv) + refers to an eval or once only + [CvEVAL(cv), CvSPECIAL(cv)] 3: HV: informally reserved by DAPM for vtables 4: Together with other flags (or @@ -414,12 +414,12 @@ perform the upgrade if necessary. See C>. isREGEXP(). */ #define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this - means that a hv_aux struct is present - after the main array */ + means that a hv_aux struct is present + after the main array */ #define SVf_BREAK 0x04000000 /* refcnt is artificially low - used by - SVs in final arena cleanup. - Set in S_regtry on PL_reg_curpm, so that - perl_destruct will skip it. + SVs in final arena cleanup. + Set in S_regtry on PL_reg_curpm, so that + perl_destruct will skip it. Used for mark and sweep by OP_AASSIGN */ #define SVf_READONLY 0x08000000 /* may not be modified */ @@ -428,10 +428,10 @@ perform the upgrade if necessary. See C>. #define SVf_THINKFIRST (SVf_READONLY|SVf_PROTECT|SVf_ROK|SVf_FAKE \ - |SVs_RMG|SVf_IsCOW) + |SVs_RMG|SVf_IsCOW) #define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \ - SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP) + SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP) #define PRIVSHIFT 4 /* (SVp_?OK >> PRIVSHIFT) == SVf_?OK */ @@ -443,14 +443,14 @@ perform the upgrade if necessary. See C>. */ #define SVf_AMAGIC 0x10000000 /* has magical overloaded methods */ #define SVf_IsCOW 0x10000000 /* copy on write (shared hash key if - SvLEN == 0) */ + SvLEN == 0) */ /* Ensure this value does not clash with the GV_ADD* flags in gv.h, or the CV_CKPROTO_* flags in op.c, or the padadd_* flags in pad.h: */ #define SVf_UTF8 0x20000000 /* SvPV is UTF-8 encoded - This is also set on RVs whose overloaded - stringification is UTF-8. This might - only happen as a side effect of SvPV() */ + This is also set on RVs whose overloaded + stringification is UTF-8. This might + only happen as a side effect of SvPV() */ /* PVHV */ #define SVphv_SHAREKEYS 0x20000000 /* PVHV keys live on shared string table */ @@ -482,7 +482,7 @@ perform the upgrade if necessary. See C>. union _xmgu xmg_u; \ STRLEN xpv_cur; /* length of svu_pv as a C string */ \ union { \ - STRLEN xpvlenu_len; /* allocated size */ \ + STRLEN xpvlenu_len; /* allocated size */ \ struct regexp* xpvlenu_rx; /* regex when SV body is XPVLV */ \ } xpv_len_u @@ -544,13 +544,13 @@ struct xpvlv { union _xivu xiv_u; union _xnvu xnv_u; union { - STRLEN xlvu_targoff; - SSize_t xlvu_stargoff; + STRLEN xlvu_targoff; + SSize_t xlvu_stargoff; } xlv_targoff_u; STRLEN xlv_targlen; SV* xlv_targ; char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re - * y=alem/helem/iter t=tie T=tied HE */ + * y=alem/helem/iter t=tie T=tied HE */ char xlv_flags; /* 1 = negative offset 2 = negative len 4 = out of range (vec) */ }; @@ -582,26 +582,26 @@ typedef U32 cv_flags_t; #define _XPVCV_COMMON \ HV * xcv_stash; \ union { \ - OP * xcv_start; \ - ANY xcv_xsubany; \ + OP * xcv_start; \ + ANY xcv_xsubany; \ } xcv_start_u; \ union { \ - OP * xcv_root; \ - void (*xcv_xsub) (pTHX_ CV*); \ + OP * xcv_root; \ + void (*xcv_xsub) (pTHX_ CV*); \ } xcv_root_u; \ union { \ - GV * xcv_gv; \ - HEK * xcv_hek; \ + GV * xcv_gv; \ + HEK * xcv_hek; \ } xcv_gv_u; \ char * xcv_file; \ union { \ - PADLIST * xcv_padlist; \ - void * xcv_hscxt; \ + PADLIST * xcv_padlist; \ + void * xcv_hscxt; \ } xcv_padlist_u; \ CV * xcv_outside; \ U32 xcv_outside_seq; /* the COP sequence (at the point of our \ - * compilation) in the lexically enclosing \ - * sub */ \ + * compilation) in the lexically enclosing \ + * sub */ \ cv_flags_t xcv_flags; \ I32 xcv_depth /* >= 2 indicates recursive call */ @@ -628,8 +628,8 @@ struct xpvio { * to hang any IO disciplines to. */ union { - DIR * xiou_dirp; /* for opendir, readdir, etc */ - void * xiou_any; /* for alignment */ + DIR * xiou_dirp; /* for opendir, readdir, etc */ + void * xiou_any; /* for alignment */ } xio_dirpu; /* IV xio_lines is now in IVX $. */ IV xio_page; /* $% */ @@ -655,7 +655,7 @@ struct xpvio { #define IOf_UNTAINT 16 /* consider this fp (and its data) "safe" */ #define IOf_NOLINE 32 /* slurped a pseudo-line from empty file */ #define IOf_FAKE_DIRP 64 /* xio_dirp is fake (source filters kludge) - Also, when this is set, SvPVX() is valid */ + Also, when this is set, SvPVX() is valid */ /* The following macros define implementation-independent predicates on SVs. */ @@ -869,45 +869,45 @@ Set the size of the string buffer for the SV. See C>. #define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK)) #define SvNIOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK)) #define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \ - SVp_IOK|SVp_NOK|SVf_IVisUV)) + SVp_IOK|SVp_NOK|SVf_IVisUV)) #define assert_not_ROK(sv) assert_(!SvROK(sv) || !SvRV(sv)) #define assert_not_glob(sv) assert_(!isGV_with_GP(sv)) #define SvOK(sv) (SvFLAGS(sv) & SVf_OK) #define SvOK_off(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK| \ - SVf_IVisUV|SVf_UTF8), \ - SvOOK_off(sv)) + SvFLAGS(sv) &= ~(SVf_OK| \ + SVf_IVisUV|SVf_UTF8), \ + SvOOK_off(sv)) #define SvOK_off_exc_UV(sv) (assert_not_ROK(sv) \ - SvFLAGS(sv) &= ~(SVf_OK| \ - SVf_UTF8), \ - SvOOK_off(sv)) + SvFLAGS(sv) &= ~(SVf_OK| \ + SVf_UTF8), \ + SvOOK_off(sv)) #define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) #define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK) #define SvIOKp_on(sv) (assert_not_glob(sv) \ - SvFLAGS(sv) |= SVp_IOK) + SvFLAGS(sv) |= SVp_IOK) #define SvNOKp(sv) (SvFLAGS(sv) & SVp_NOK) #define SvNOKp_on(sv) (assert_not_glob(sv) SvFLAGS(sv) |= SVp_NOK) #define SvPOKp(sv) (SvFLAGS(sv) & SVp_POK) #define SvPOKp_on(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) |= SVp_POK) + SvFLAGS(sv) |= SVp_POK) #define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK) #define SvIOK_on(sv) (assert_not_glob(sv) \ - SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV)) #define SvIOK_only(sv) (SvOK_off(sv), \ - SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_only_UV(sv) (assert_not_glob(sv) SvOK_off_exc_UV(sv), \ - SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ - == (SVf_IOK|SVf_IVisUV)) + == (SVf_IOK|SVf_IVisUV)) #define SvUOK(sv) SvIOK_UV(sv) #define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ - == SVf_IOK) + == SVf_IOK) #define SvIsUV(sv) (SvFLAGS(sv) & SVf_IVisUV) #define SvIsUV_on(sv) (SvFLAGS(sv) |= SVf_IVisUV) @@ -915,10 +915,10 @@ Set the size of the string buffer for the SV. See C>. #define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK) #define SvNOK_on(sv) (assert_not_glob(sv) \ - SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) + SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) #define SvNOK_off(sv) (SvFLAGS(sv) &= ~(SVf_NOK|SVp_NOK)) #define SvNOK_only(sv) (SvOK_off(sv), \ - SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) + SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) /* =for apidoc Am|U32|SvUTF8|SV* sv @@ -953,19 +953,19 @@ in gv.h: */ #define SvPOK(sv) (SvFLAGS(sv) & SVf_POK) #define SvPOK_on(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) |= (SVf_POK|SVp_POK)) + SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK)) #define SvPOK_only(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK| \ - SVf_IVisUV|SVf_UTF8), \ - SvFLAGS(sv) |= (SVf_POK|SVp_POK)) + SvFLAGS(sv) &= ~(SVf_OK| \ + SVf_IVisUV|SVf_UTF8), \ + SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_only_UTF8(sv) (assert_not_ROK(sv) assert_not_glob(sv) \ - SvFLAGS(sv) &= ~(SVf_OK| \ - SVf_IVisUV), \ - SvFLAGS(sv) |= (SVf_POK|SVp_POK)) + SvFLAGS(sv) &= ~(SVf_OK| \ + SVf_IVisUV), \ + SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvVOK(sv) (SvMAGICAL(sv) \ - && mg_find(sv,PERL_MAGIC_vstring)) + && mg_find(sv,PERL_MAGIC_vstring)) /* =for apidoc Am|MAGIC*|SvVSTRING_mg|SV * sv @@ -974,7 +974,7 @@ Returns the vstring magic, or NULL if none =cut */ #define SvVSTRING_mg(sv) (SvMAGICAL(sv) \ - ? mg_find(sv,PERL_MAGIC_vstring) : NULL) + ? mg_find(sv,PERL_MAGIC_vstring) : NULL) #define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK) #define SvOOK_on(sv) (SvFLAGS(sv) |= SVf_OOK) @@ -1015,7 +1015,7 @@ Remove any string offset. #define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG) #define SvAMAGIC(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)) && \ - HvAMAGIC(SvSTASH(SvRV(sv)))) + HvAMAGIC(SvSTASH(SvRV(sv)))) /* To be used on the stashes themselves: */ #define HvAMAGIC(hv) (SvFLAGS(hv) & SVf_AMAGIC) @@ -1066,17 +1066,17 @@ the scalar's value cannot change unless written to. #define SvGAMAGIC(sv) (SvGMAGICAL(sv) || SvAMAGIC(sv)) #define Gv_AMG(stash) \ - (HvNAME(stash) && Gv_AMupdate(stash,FALSE) \ - ? 1 \ - : (HvAMAGIC_off(stash), 0)) + (HvNAME(stash) && Gv_AMupdate(stash,FALSE) \ + ? 1 \ + : (HvAMAGIC_off(stash), 0)) #define SvWEAKREF(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \ - == (SVf_ROK|SVprv_WEAKREF)) + == (SVf_ROK|SVprv_WEAKREF)) #define SvWEAKREF_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_WEAKREF)) #define SvWEAKREF_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF)) #define SvPCS_IMPORTED(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_PCS_IMPORTED)) \ - == (SVf_ROK|SVprv_PCS_IMPORTED)) + == (SVf_ROK|SVprv_PCS_IMPORTED)) #define SvPCS_IMPORTED_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_PCS_IMPORTED)) #define SvPCS_IMPORTED_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_PCS_IMPORTED)) @@ -1166,12 +1166,12 @@ object type. Exposed to perl code via Internals::SvREADONLY(). #if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) # define SvTAIL(sv) ({ const SV *const _svtail = (const SV *)(sv); \ - assert(SvTYPE(_svtail) != SVt_PVAV); \ - assert(SvTYPE(_svtail) != SVt_PVHV); \ - assert(!(SvFLAGS(_svtail) & (SVf_NOK|SVp_NOK))); \ - assert(SvVALID(_svtail)); \ + assert(SvTYPE(_svtail) != SVt_PVAV); \ + assert(SvTYPE(_svtail) != SVt_PVHV); \ + assert(!(SvFLAGS(_svtail) & (SVf_NOK|SVp_NOK))); \ + assert(SvVALID(_svtail)); \ ((XPVNV*)SvANY(_svtail))->xnv_u.xnv_bm_tail; \ - }) + }) #else # define SvTAIL(_svtail) (((XPVNV*)SvANY(_svtail))->xnv_u.xnv_bm_tail) #endif @@ -1219,76 +1219,76 @@ object type. Exposed to perl code via Internals::SvREADONLY(). # if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) /* These get expanded inside other macros that already use a variable _sv */ # define SvPVX(sv) \ - (*({ SV *const _svpvx = MUTABLE_SV(sv); \ - assert(PL_valid_types_PVX[SvTYPE(_svpvx) & SVt_MASK]); \ - assert(!isGV_with_GP(_svpvx)); \ - assert(!(SvTYPE(_svpvx) == SVt_PVIO \ - && !(IoFLAGS(_svpvx) & IOf_FAKE_DIRP))); \ - &((_svpvx)->sv_u.svu_pv); \ - })) + (*({ SV *const _svpvx = MUTABLE_SV(sv); \ + assert(PL_valid_types_PVX[SvTYPE(_svpvx) & SVt_MASK]); \ + assert(!isGV_with_GP(_svpvx)); \ + assert(!(SvTYPE(_svpvx) == SVt_PVIO \ + && !(IoFLAGS(_svpvx) & IOf_FAKE_DIRP))); \ + &((_svpvx)->sv_u.svu_pv); \ + })) # ifdef PERL_CORE # define SvCUR(sv) \ - ({ const SV *const _svcur = (const SV *)(sv); \ - assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]); \ - assert(!isGV_with_GP(_svcur)); \ - assert(!(SvTYPE(_svcur) == SVt_PVIO \ - && !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \ - (((XPV*) MUTABLE_PTR(SvANY(_svcur)))->xpv_cur); \ - }) + ({ const SV *const _svcur = (const SV *)(sv); \ + assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]); \ + assert(!isGV_with_GP(_svcur)); \ + assert(!(SvTYPE(_svcur) == SVt_PVIO \ + && !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \ + (((XPV*) MUTABLE_PTR(SvANY(_svcur)))->xpv_cur); \ + }) # else # define SvCUR(sv) \ - (*({ const SV *const _svcur = (const SV *)(sv); \ - assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]); \ - assert(!isGV_with_GP(_svcur)); \ - assert(!(SvTYPE(_svcur) == SVt_PVIO \ - && !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \ - &(((XPV*) MUTABLE_PTR(SvANY(_svcur)))->xpv_cur); \ - })) + (*({ const SV *const _svcur = (const SV *)(sv); \ + assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]); \ + assert(!isGV_with_GP(_svcur)); \ + assert(!(SvTYPE(_svcur) == SVt_PVIO \ + && !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \ + &(((XPV*) MUTABLE_PTR(SvANY(_svcur)))->xpv_cur); \ + })) # endif # define SvIVX(sv) \ - (*({ const SV *const _svivx = (const SV *)(sv); \ - assert(PL_valid_types_IVX[SvTYPE(_svivx) & SVt_MASK]); \ - assert(!isGV_with_GP(_svivx)); \ - &(((XPVIV*) MUTABLE_PTR(SvANY(_svivx)))->xiv_iv); \ - })) + (*({ const SV *const _svivx = (const SV *)(sv); \ + assert(PL_valid_types_IVX[SvTYPE(_svivx) & SVt_MASK]); \ + assert(!isGV_with_GP(_svivx)); \ + &(((XPVIV*) MUTABLE_PTR(SvANY(_svivx)))->xiv_iv); \ + })) # define SvUVX(sv) \ - (*({ const SV *const _svuvx = (const SV *)(sv); \ - assert(PL_valid_types_IVX[SvTYPE(_svuvx) & SVt_MASK]); \ - assert(!isGV_with_GP(_svuvx)); \ - &(((XPVUV*) MUTABLE_PTR(SvANY(_svuvx)))->xuv_uv); \ - })) + (*({ const SV *const _svuvx = (const SV *)(sv); \ + assert(PL_valid_types_IVX[SvTYPE(_svuvx) & SVt_MASK]); \ + assert(!isGV_with_GP(_svuvx)); \ + &(((XPVUV*) MUTABLE_PTR(SvANY(_svuvx)))->xuv_uv); \ + })) # define SvNVX(sv) \ - (*({ const SV *const _svnvx = (const SV *)(sv); \ - assert(PL_valid_types_NVX[SvTYPE(_svnvx) & SVt_MASK]); \ - assert(!isGV_with_GP(_svnvx)); \ - &(((XPVNV*) MUTABLE_PTR(SvANY(_svnvx)))->xnv_u.xnv_nv); \ - })) + (*({ const SV *const _svnvx = (const SV *)(sv); \ + assert(PL_valid_types_NVX[SvTYPE(_svnvx) & SVt_MASK]); \ + assert(!isGV_with_GP(_svnvx)); \ + &(((XPVNV*) MUTABLE_PTR(SvANY(_svnvx)))->xnv_u.xnv_nv); \ + })) # define SvRV(sv) \ - (*({ SV *const _svrv = MUTABLE_SV(sv); \ - assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \ - assert(!isGV_with_GP(_svrv)); \ - assert(!(SvTYPE(_svrv) == SVt_PVIO \ - && !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \ - &((_svrv)->sv_u.svu_rv); \ - })) + (*({ SV *const _svrv = MUTABLE_SV(sv); \ + assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \ + assert(!isGV_with_GP(_svrv)); \ + assert(!(SvTYPE(_svrv) == SVt_PVIO \ + && !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \ + &((_svrv)->sv_u.svu_rv); \ + })) # define SvRV_const(sv) \ - ({ const SV *const _svrv = (const SV *)(sv); \ - assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \ - assert(!isGV_with_GP(_svrv)); \ - assert(!(SvTYPE(_svrv) == SVt_PVIO \ - && !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \ - (_svrv)->sv_u.svu_rv; \ - }) + ({ const SV *const _svrv = (const SV *)(sv); \ + assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \ + assert(!isGV_with_GP(_svrv)); \ + assert(!(SvTYPE(_svrv) == SVt_PVIO \ + && !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \ + (_svrv)->sv_u.svu_rv; \ + }) # define SvMAGIC(sv) \ - (*({ const SV *const _svmagic = (const SV *)(sv); \ - assert(SvTYPE(_svmagic) >= SVt_PVMG); \ - &(((XPVMG*) MUTABLE_PTR(SvANY(_svmagic)))->xmg_u.xmg_magic); \ - })) + (*({ const SV *const _svmagic = (const SV *)(sv); \ + assert(SvTYPE(_svmagic) >= SVt_PVMG); \ + &(((XPVMG*) MUTABLE_PTR(SvANY(_svmagic)))->xmg_u.xmg_magic); \ + })) # define SvSTASH(sv) \ - (*({ const SV *const _svstash = (const SV *)(sv); \ - assert(SvTYPE(_svstash) >= SVt_PVMG); \ - &(((XPVMG*) MUTABLE_PTR(SvANY(_svstash)))->xmg_stash); \ - })) + (*({ const SV *const _svstash = (const SV *)(sv); \ + assert(SvTYPE(_svstash) >= SVt_PVMG); \ + &(((XPVMG*) MUTABLE_PTR(SvANY(_svstash)))->xmg_stash); \ + })) # else /* Below is not DEBUGGING or can't use brace groups */ # define SvPVX(sv) ((sv)->sv_u.svu_pv) # define SvCUR(sv) ((XPV*) SvANY(sv))->xpv_cur @@ -1326,40 +1326,40 @@ object type. Exposed to perl code via Internals::SvREADONLY(). Not guaranteed to stay returning void */ /* Macro won't actually call sv_2iv if already IOK */ #define SvIV_please(sv) \ - STMT_START {if (!SvIOKp(sv) && (SvFLAGS(sv) & (SVf_NOK|SVf_POK))) \ - (void) SvIV(sv); } STMT_END + STMT_START {if (!SvIOKp(sv) && (SvFLAGS(sv) & (SVf_NOK|SVf_POK))) \ + (void) SvIV(sv); } STMT_END #define SvIV_please_nomg(sv) \ - (!(SvFLAGS(sv) & (SVf_IOK|SVp_IOK)) && (SvFLAGS(sv) & (SVf_NOK|SVf_POK)) \ - ? (sv_2iv_flags(sv, 0), SvIOK(sv)) \ - : SvIOK(sv)) + (!(SvFLAGS(sv) & (SVf_IOK|SVp_IOK)) && (SvFLAGS(sv) & (SVf_NOK|SVf_POK)) \ + ? (sv_2iv_flags(sv, 0), SvIOK(sv)) \ + : SvIOK(sv)) #define SvIV_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - (((XPVIV*) SvANY(sv))->xiv_iv = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (val)); } STMT_END #define SvNV_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_NV_set[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - (((XPVNV*)SvANY(sv))->xnv_u.xnv_nv = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_NV_set[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + (((XPVNV*)SvANY(sv))->xnv_u.xnv_nv = (val)); } STMT_END #define SvPV_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - assert(!(SvTYPE(sv) == SVt_PVIO \ - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ - ((sv)->sv_u.svu_pv = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + assert(!(SvTYPE(sv) == SVt_PVIO \ + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ + ((sv)->sv_u.svu_pv = (val)); } STMT_END #define SvUV_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - (((XPVUV*)SvANY(sv))->xuv_uv = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + (((XPVUV*)SvANY(sv))->xuv_uv = (val)); } STMT_END #define SvRV_set(sv, val) \ STMT_START { \ - assert(PL_valid_types_RV[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - assert(!(SvTYPE(sv) == SVt_PVIO \ - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ + assert(PL_valid_types_RV[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + assert(!(SvTYPE(sv) == SVt_PVIO \ + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ @@ -1368,22 +1368,22 @@ object type. Exposed to perl code via Internals::SvREADONLY(). STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #define SvCUR_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - assert(!(SvTYPE(sv) == SVt_PVIO \ - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ - (((XPV*) SvANY(sv))->xpv_cur = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + assert(!(SvTYPE(sv) == SVt_PVIO \ + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ + (((XPV*) SvANY(sv))->xpv_cur = (val)); } STMT_END #define SvLEN_set(sv, val) \ - STMT_START { \ - assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ - assert(!isGV_with_GP(sv)); \ - assert(!(SvTYPE(sv) == SVt_PVIO \ - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ - (((XPV*) SvANY(sv))->xpv_len = (val)); } STMT_END + STMT_START { \ + assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \ + assert(!isGV_with_GP(sv)); \ + assert(!(SvTYPE(sv) == SVt_PVIO \ + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \ + (((XPV*) SvANY(sv))->xpv_len = (val)); } STMT_END #define SvEND_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) >= SVt_PV); \ - SvCUR_set(sv, (val) - SvPVX(sv)); } STMT_END + STMT_START { assert(SvTYPE(sv) >= SVt_PV); \ + SvCUR_set(sv, (val) - SvPVX(sv)); } STMT_END /* =for apidoc Am|void|SvPV_renew|SV* sv|STRLEN len @@ -1397,16 +1397,16 @@ why not just use C if you're not sure about the provenance? =cut */ #define SvPV_renew(sv,n) \ - STMT_START { SvLEN_set(sv, n); \ - SvPV_set((sv), (MEM_WRAP_CHECK_(n,char) \ - (char*)saferealloc((Malloc_t)SvPVX(sv), \ - (MEM_SIZE)((n))))); \ - } STMT_END + STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (MEM_WRAP_CHECK_(n,char) \ + (char*)saferealloc((Malloc_t)SvPVX(sv), \ + (MEM_SIZE)((n))))); \ + } STMT_END #define SvPV_shrink_to_cur(sv) STMT_START { \ - const STRLEN _lEnGtH = SvCUR(sv) + 1; \ - SvPV_renew(sv, _lEnGtH); \ - } STMT_END + const STRLEN _lEnGtH = SvCUR(sv) + 1; \ + SvPV_renew(sv, _lEnGtH); \ + } STMT_END /* =for apidoc Am|void|SvPV_free|SV * sv @@ -1418,32 +1418,32 @@ only be used as part of a larger operation */ #define SvPV_free(sv) \ STMT_START { \ - assert(SvTYPE(sv) >= SVt_PV); \ - if (SvLEN(sv)) { \ - assert(!SvROK(sv)); \ - if(UNLIKELY(SvOOK(sv))) { \ - STRLEN zok; \ - SvOOK_offset(sv, zok); \ - SvPV_set(sv, SvPVX_mutable(sv) - zok); \ - SvFLAGS(sv) &= ~SVf_OOK; \ - } \ - Safefree(SvPVX(sv)); \ - } \ - } STMT_END + assert(SvTYPE(sv) >= SVt_PV); \ + if (SvLEN(sv)) { \ + assert(!SvROK(sv)); \ + if(UNLIKELY(SvOOK(sv))) { \ + STRLEN zok; \ + SvOOK_offset(sv, zok); \ + SvPV_set(sv, SvPVX_mutable(sv) - zok); \ + SvFLAGS(sv) &= ~SVf_OOK; \ + } \ + Safefree(SvPVX(sv)); \ + } \ + } STMT_END #ifdef PERL_CORE /* Code that crops up in three places to take a scalar and ready it to hold a reference */ # define prepare_SV_for_RV(sv) \ STMT_START { \ - if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) \ - sv_upgrade(sv, SVt_IV); \ - else if (SvTYPE(sv) >= SVt_PV) { \ - SvPV_free(sv); \ - SvLEN_set(sv, 0); \ + if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) \ + sv_upgrade(sv, SVt_IV); \ + else if (SvTYPE(sv) >= SVt_PV) { \ + SvPV_free(sv); \ + SvLEN_set(sv, 0); \ SvCUR_set(sv, 0); \ - } \ - } STMT_END + } \ + } STMT_END #endif #ifndef PERL_CORE @@ -1452,12 +1452,12 @@ only be used as part of a larger operation #if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) # define BmUSEFUL(sv) \ - (*({ SV *const _bmuseful = MUTABLE_SV(sv); \ - assert(SvTYPE(_bmuseful) >= SVt_PVIV); \ - assert(SvVALID(_bmuseful)); \ - assert(!SvIOK(_bmuseful)); \ - &(((XPVIV*) SvANY(_bmuseful))->xiv_u.xivu_iv); \ - })) + (*({ SV *const _bmuseful = MUTABLE_SV(sv); \ + assert(SvTYPE(_bmuseful) >= SVt_PVIV); \ + assert(SvVALID(_bmuseful)); \ + assert(!SvIOK(_bmuseful)); \ + &(((XPVIV*) SvANY(_bmuseful))->xiv_u.xivu_iv); \ + })) #else # define BmUSEFUL(sv) ((XPVIV*) SvANY(sv))->xiv_u.xivu_iv @@ -2000,11 +2000,11 @@ scalar. #define SvPVXtrue(sv) ( \ ((XPV*)SvANY((sv))) \ && ( \ - ((XPV*)SvANY((sv)))->xpv_cur > 1 \ - || ( \ - ((XPV*)SvANY((sv)))->xpv_cur \ - && *(sv)->sv_u.svu_pv != '0' \ - ) \ + ((XPV*)SvANY((sv)))->xpv_cur > 1 \ + || ( \ + ((XPV*)SvANY((sv)))->xpv_cur \ + && *(sv)->sv_u.svu_pv != '0' \ + ) \ ) \ ) @@ -2014,7 +2014,7 @@ scalar. #define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0) #define SvSHARED_HEK_FROM_PV(pvx) \ - ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key))) + ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key))) /* =for apidoc Am|struct hek*|SvSHARED_HASH|SV * sv Returns the hash for C created by C>. @@ -2084,25 +2084,25 @@ Returns the hash for C created by C>. discarded. */ #define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \ - sv_force_normal_flags(sv, SV_COW_DROP_PV) + sv_force_normal_flags(sv, SV_COW_DROP_PV) #ifdef PERL_COPY_ON_WRITE # define SvCANCOW(sv) \ - (SvIsCOW(sv) \ - ? SvLEN(sv) ? CowREFCNT(sv) != SV_COW_REFCNT_MAX : 1 \ - : (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS \ - && SvCUR(sv)+1 < SvLEN(sv)) + (SvIsCOW(sv) \ + ? SvLEN(sv) ? CowREFCNT(sv) != SV_COW_REFCNT_MAX : 1 \ + : (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS \ + && SvCUR(sv)+1 < SvLEN(sv)) /* Note: To allow 256 COW "copies", a refcnt of 0 means 1. */ # define CowREFCNT(sv) (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1)) # define SV_COW_REFCNT_MAX nBIT_UMAX(sizeof(U8) * CHARBITS) # define CAN_COW_MASK (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \ - SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT) + SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT) #endif #define CAN_COW_FLAGS (SVp_POK|SVf_POK) #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \ - sv_force_normal_flags(sv, 0) + sv_force_normal_flags(sv, 0) /* all these 'functions' are now just macros */ @@ -2119,7 +2119,7 @@ Returns the hash for C created by C>. #define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0) #define sv_catpv_nomg(dsv, sstr) sv_catpv_flags(dsv, sstr, 0) #define sv_setsv(dsv, ssv) \ - sv_setsv_flags(dsv, ssv, SV_GMAGIC|SV_DO_COW_SVSETSV) + sv_setsv_flags(dsv, ssv, SV_GMAGIC|SV_DO_COW_SVSETSV) #define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_DO_COW_SVSETSV) #define sv_catsv(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC) #define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0) @@ -2147,36 +2147,36 @@ Returns the hash for C created by C>. #define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC) #define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0) #define sv_insert(bigstr, offset, len, little, littlelen) \ - Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little), \ - (littlelen), SV_GMAGIC) + Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little), \ + (littlelen), SV_GMAGIC) #define sv_mortalcopy(sv) \ - Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV) + Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV) #define sv_cathek(sv,hek) \ - STMT_START { \ - HEK * const bmxk = hek; \ - sv_catpvn_flags(sv, HEK_KEY(bmxk), HEK_LEN(bmxk), \ - HEK_UTF8(bmxk) ? SV_CATUTF8 : SV_CATBYTES); \ - } STMT_END + STMT_START { \ + HEK * const bmxk = hek; \ + sv_catpvn_flags(sv, HEK_KEY(bmxk), HEK_LEN(bmxk), \ + HEK_UTF8(bmxk) ? SV_CATUTF8 : SV_CATBYTES); \ + } STMT_END /* Should be named SvCatPVN_utf8_upgrade? */ #define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \ - STMT_START { \ - if (!(nsv)) \ - nsv = newSVpvn_flags(sstr, slen, SVs_TEMP); \ - else \ - sv_setpvn(nsv, sstr, slen); \ - SvUTF8_off(nsv); \ - sv_utf8_upgrade(nsv); \ - sv_catsv_nomg(dsv, nsv); \ - } STMT_END + STMT_START { \ + if (!(nsv)) \ + nsv = newSVpvn_flags(sstr, slen, SVs_TEMP); \ + else \ + sv_setpvn(nsv, sstr, slen); \ + SvUTF8_off(nsv); \ + sv_utf8_upgrade(nsv); \ + sv_catsv_nomg(dsv, nsv); \ + } STMT_END #define sv_catpvn_nomg_maybeutf8(dsv, sstr, slen, is_utf8) \ - sv_catpvn_flags(dsv, sstr, slen, (is_utf8)?SV_CATUTF8:SV_CATBYTES) + sv_catpvn_flags(dsv, sstr, slen, (is_utf8)?SV_CATUTF8:SV_CATBYTES) #if defined(PERL_CORE) || defined(PERL_EXT) # define sv_or_pv_len_utf8(sv, pv, bytelen) \ (SvGAMAGIC(sv) \ - ? utf8_length((U8 *)(pv), (U8 *)(pv)+(bytelen)) \ - : sv_len_utf8(sv)) + ? utf8_length((U8 *)(pv), (U8 *)(pv)+(bytelen)) \ + : sv_len_utf8(sv)) #endif /* @@ -2266,29 +2266,29 @@ properly null terminated. Equivalent to sv_setpvs(""), but more efficient. #define SvSETMAGIC(x) STMT_START { if (UNLIKELY(SvSMAGICAL(x))) mg_set(x); } STMT_END #define SvSetSV_and(dst,src,finally) \ - STMT_START { \ - if (LIKELY((dst) != (src))) { \ - sv_setsv(dst, src); \ - finally; \ - } \ - } STMT_END + STMT_START { \ + if (LIKELY((dst) != (src))) { \ + sv_setsv(dst, src); \ + finally; \ + } \ + } STMT_END #define SvSetSV_nosteal_and(dst,src,finally) \ - STMT_START { \ - if (LIKELY((dst) != (src))) { \ - sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL | SV_DO_COW_SVSETSV); \ - finally; \ - } \ - } STMT_END + STMT_START { \ + if (LIKELY((dst) != (src))) { \ + sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL | SV_DO_COW_SVSETSV); \ + finally; \ + } \ + } STMT_END #define SvSetSV(dst,src) \ - SvSetSV_and(dst,src,/*nothing*/;) + SvSetSV_and(dst,src,/*nothing*/;) #define SvSetSV_nosteal(dst,src) \ - SvSetSV_nosteal_and(dst,src,/*nothing*/;) + SvSetSV_nosteal_and(dst,src,/*nothing*/;) #define SvSetMagicSV(dst,src) \ - SvSetSV_and(dst,src,SvSETMAGIC(dst)) + SvSetSV_and(dst,src,SvSETMAGIC(dst)) #define SvSetMagicSV_nosteal(dst,src) \ - SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) + SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) #if !defined(SKIP_DEBUGGING) @@ -2342,19 +2342,19 @@ Returns a boolean as to whether or not C is a GV with a pointer to a GP =cut */ #define isGV_with_GP(pwadak) \ - (((SvFLAGS(pwadak) & (SVp_POK|SVpgv_GP)) == SVpgv_GP) \ - && (SvTYPE(pwadak) == SVt_PVGV || SvTYPE(pwadak) == SVt_PVLV)) + (((SvFLAGS(pwadak) & (SVp_POK|SVpgv_GP)) == SVpgv_GP) \ + && (SvTYPE(pwadak) == SVt_PVGV || SvTYPE(pwadak) == SVt_PVLV)) #define isGV_with_GP_on(sv) STMT_START { \ - assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \ - assert (!SvPOKp(sv)); \ - assert (!SvIOKp(sv)); \ - (SvFLAGS(sv) |= SVpgv_GP); \ + assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \ + assert (!SvPOKp(sv)); \ + assert (!SvIOKp(sv)); \ + (SvFLAGS(sv) |= SVpgv_GP); \ } STMT_END #define isGV_with_GP_off(sv) STMT_START { \ - assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \ - assert (!SvPOKp(sv)); \ - assert (!SvIOKp(sv)); \ - (SvFLAGS(sv) &= ~SVpgv_GP); \ + assert (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); \ + assert (!SvPOKp(sv)); \ + assert (!SvIOKp(sv)); \ + (SvFLAGS(sv) &= ~SVpgv_GP); \ } STMT_END #ifdef PERL_CORE # define isGV_or_RVCV(kadawp) \ @@ -2363,12 +2363,12 @@ Returns a boolean as to whether or not C is a GV with a pointer to a GP #define isREGEXP(sv) \ (SvTYPE(sv) == SVt_REGEXP \ || (SvFLAGS(sv) & (SVTYPEMASK|SVpgv_GP|SVf_FAKE)) \ - == (SVt_PVLV|SVf_FAKE)) + == (SVt_PVLV|SVf_FAKE)) #ifdef PERL_ANY_COW # define SvGROW(sv,len) \ - (SvIsCOW(sv) || SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) + (SvIsCOW(sv) || SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) #else # define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) #endif @@ -2434,40 +2434,40 @@ Evaluates C more than once. Sets C to 0 if C is false. 10:28 <+meta> Nicholas: crash */ # define SvOOK_offset(sv, offset) STMT_START { \ - STATIC_ASSERT_STMT(sizeof(offset) == sizeof(STRLEN)); \ - if (SvOOK(sv)) { \ - const U8 *_crash = (U8*)SvPVX_const(sv); \ - (offset) = *--_crash; \ - if (!(offset)) { \ - _crash -= sizeof(STRLEN); \ - Copy(_crash, (U8 *)&(offset), sizeof(STRLEN), U8); \ - } \ - { \ - /* Validate the preceding buffer's sentinels to \ - verify that no-one is using it. */ \ - const U8 *const _bonk = (U8*)SvPVX_const(sv) - (offset);\ - while (_crash > _bonk) { \ - --_crash; \ - assert (*_crash == (U8)PTR2UV(_crash)); \ - } \ - } \ - } else { \ - (offset) = 0; \ - } \ + STATIC_ASSERT_STMT(sizeof(offset) == sizeof(STRLEN)); \ + if (SvOOK(sv)) { \ + const U8 *_crash = (U8*)SvPVX_const(sv); \ + (offset) = *--_crash; \ + if (!(offset)) { \ + _crash -= sizeof(STRLEN); \ + Copy(_crash, (U8 *)&(offset), sizeof(STRLEN), U8); \ + } \ + { \ + /* Validate the preceding buffer's sentinels to \ + verify that no-one is using it. */ \ + const U8 *const _bonk = (U8*)SvPVX_const(sv) - (offset);\ + while (_crash > _bonk) { \ + --_crash; \ + assert (*_crash == (U8)PTR2UV(_crash)); \ + } \ + } \ + } else { \ + (offset) = 0; \ + } \ } STMT_END #else /* This is the same code, but avoids using any temporary variables: */ # define SvOOK_offset(sv, offset) STMT_START { \ - STATIC_ASSERT_STMT(sizeof(offset) == sizeof(STRLEN)); \ - if (SvOOK(sv)) { \ - (offset) = ((U8*)SvPVX_const(sv))[-1]; \ - if (!(offset)) { \ - Copy(SvPVX_const(sv) - 1 - sizeof(STRLEN), \ - (U8*)&(offset), sizeof(STRLEN), U8); \ - } \ - } else { \ - (offset) = 0; \ - } \ + STATIC_ASSERT_STMT(sizeof(offset) == sizeof(STRLEN)); \ + if (SvOOK(sv)) { \ + (offset) = ((U8*)SvPVX_const(sv))[-1]; \ + if (!(offset)) { \ + Copy(SvPVX_const(sv) - 1 - sizeof(STRLEN), \ + (U8*)&(offset), sizeof(STRLEN), U8); \ + } \ + } else { \ + (offset) = 0; \ + } \ } STMT_END #endif @@ -2476,9 +2476,9 @@ Evaluates C more than once. Sets C to 0 if C is false. #if defined(PERL_CORE) || defined(PERL_EXT) # define SV_CONST(name) \ - PL_sv_consts[SV_CONST_##name] \ - ? PL_sv_consts[SV_CONST_##name] \ - : (PL_sv_consts[SV_CONST_##name] = newSVpv_share(#name, 0)) + PL_sv_consts[SV_CONST_##name] \ + ? PL_sv_consts[SV_CONST_##name] \ + : (PL_sv_consts[SV_CONST_##name] = newSVpv_share(#name, 0)) # define SV_CONST_TIESCALAR 0 # define SV_CONST_TIEARRAY 1 @@ -2550,11 +2550,11 @@ Evaluates C more than once. Sets C to 0 if C is false. #ifdef PERL_CORE # define SET_SVANY_FOR_BODYLESS_IV(sv) \ - SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) \ + SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) \ - STRUCT_OFFSET(XPVIV, xiv_iv)) # define SET_SVANY_FOR_BODYLESS_NV(sv) \ - SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) \ + SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) \ - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv)) #endif diff --git a/toke.c b/toke.c index 628a79fb4320..71503b75c217 100644 --- a/toke.c +++ b/toke.c @@ -41,7 +41,7 @@ Individual members of C have their own documentation. #include "invlist_inline.h" #define new_constant(a,b,c,d,e,f,g, h) \ - S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g, h) + S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g, h) #define pl_yylval (PL_parser->yylval) @@ -138,12 +138,12 @@ static const char* const ident_var_zero_multi_digit = "Numeric variables with mo #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */ #define LEX_INTERPSTART 6 /* expecting the start of a $var */ - /* at end of code, eg "$x" followed by: */ + /* at end of code, eg "$x" followed by: */ #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */ #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */ #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of - string or after \E, $foo, etc */ + string or after \E, $foo, etc */ #define LEX_INTERPCONST 2 /* NOT USED */ #define LEX_FORMLINE 1 /* expecting a format line */ @@ -228,9 +228,9 @@ static const char* const lex_state_names[] = { #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1])) #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \ - pl_yylval.ival=f, \ - PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \ - REPORT((int)LOOPEX)) + pl_yylval.ival=f, \ + PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \ + REPORT((int)LOOPEX)) #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP)) @@ -238,7 +238,7 @@ static const char* const lex_state_names[] = { #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP)) #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP)) #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \ - REPORT(PERLY_TILDE) + REPORT(PERLY_TILDE) #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP)) #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP)) #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) @@ -256,50 +256,50 @@ static const char* const lex_state_names[] = { * operator (such as C). */ #define UNI3(f,x,have_x) { \ - pl_yylval.ival = f; \ - if (have_x) PL_expect = x; \ - PL_bufptr = s; \ - PL_last_uni = PL_oldbufptr; \ - PL_last_lop_op = (f) < 0 ? -(f) : (f); \ - if (*s == '(') \ - return REPORT( (int)FUNC1 ); \ - s = skipspace(s); \ - return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ - } + pl_yylval.ival = f; \ + if (have_x) PL_expect = x; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + PL_last_lop_op = (f) < 0 ? -(f) : (f); \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ + } #define UNI(f) UNI3(f,XTERM,1) #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1) #define UNIPROTO(f,optional) { \ - if (optional) PL_last_uni = PL_oldbufptr; \ - OPERATOR(f); \ - } + if (optional) PL_last_uni = PL_oldbufptr; \ + OPERATOR(f); \ + } #define UNIBRACK(f) UNI3(f,0,0) /* grandfather return to old style */ #define OLDLOP(f) \ - do { \ - if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \ - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \ - pl_yylval.ival = (f); \ - PL_expect = XTERM; \ - PL_bufptr = s; \ - return (int)LSTOP; \ - } while(0) + do { \ + if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \ + PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \ + pl_yylval.ival = (f); \ + PL_expect = XTERM; \ + PL_bufptr = s; \ + return (int)LSTOP; \ + } while(0) #define COPLINE_INC_WITH_HERELINES \ STMT_START { \ - CopLINE_inc(PL_curcop); \ - if (PL_parser->herelines) \ - CopLINE(PL_curcop) += PL_parser->herelines, \ - PL_parser->herelines = 0; \ + CopLINE_inc(PL_curcop); \ + if (PL_parser->herelines) \ + CopLINE(PL_curcop) += PL_parser->herelines, \ + PL_parser->herelines = 0; \ } STMT_END /* Called after scan_str to update CopLINE(PL_curcop), but only when there * is no sublex_push to follow. */ #define COPLINE_SET_FROM_MULTI_END \ STMT_START { \ - CopLINE_set(PL_curcop, PL_multi_end); \ - if (PL_multi_end != PL_multi_start) \ - PL_parser->herelines = 0; \ + CopLINE_set(PL_curcop, PL_multi_end); \ + if (PL_multi_end != PL_multi_start) \ + PL_parser->herelines = 0; \ } STMT_END @@ -449,57 +449,57 @@ S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) PERL_ARGS_ASSERT_TOKEREPORT; if (DEBUG_T_TEST) { - const char *name = NULL; - enum token_type type = TOKENTYPE_NONE; - const struct debug_tokens *p; - SV* const report = newSVpvs("<== "); - - for (p = debug_tokens; p->token; p++) { - if (p->token == (int)rv) { - name = p->name; - type = p->type; - break; - } - } - if (name) - Perl_sv_catpv(aTHX_ report, name); - else if (isGRAPH(rv)) - { - Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); - if ((char)rv == 'p') - sv_catpvs(report, " (pending identifier)"); - } - else if (!rv) - sv_catpvs(report, "EOF"); - else - Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv); - switch (type) { - case TOKENTYPE_NONE: - break; - case TOKENTYPE_IVAL: - Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival); - break; - case TOKENTYPE_OPNUM: - Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", - PL_op_name[lvalp->ival]); - break; - case TOKENTYPE_PVAL: - Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval); - break; - case TOKENTYPE_OPVAL: - if (lvalp->opval) { - Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", - PL_op_name[lvalp->opval->op_type]); - if (lvalp->opval->op_type == OP_CONST) { - Perl_sv_catpvf(aTHX_ report, " %s", - SvPEEK(cSVOPx_sv(lvalp->opval))); - } - - } - else - sv_catpvs(report, "(opval=null)"); - break; - } + const char *name = NULL; + enum token_type type = TOKENTYPE_NONE; + const struct debug_tokens *p; + SV* const report = newSVpvs("<== "); + + for (p = debug_tokens; p->token; p++) { + if (p->token == (int)rv) { + name = p->name; + type = p->type; + break; + } + } + if (name) + Perl_sv_catpv(aTHX_ report, name); + else if (isGRAPH(rv)) + { + Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); + if ((char)rv == 'p') + sv_catpvs(report, " (pending identifier)"); + } + else if (!rv) + sv_catpvs(report, "EOF"); + else + Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv); + switch (type) { + case TOKENTYPE_NONE: + break; + case TOKENTYPE_IVAL: + Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival); + break; + case TOKENTYPE_OPNUM: + Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", + PL_op_name[lvalp->ival]); + break; + case TOKENTYPE_PVAL: + Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval); + break; + case TOKENTYPE_OPVAL: + if (lvalp->opval) { + Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", + PL_op_name[lvalp->opval->op_type]); + if (lvalp->opval->op_type == OP_CONST) { + Perl_sv_catpvf(aTHX_ report, " %s", + SvPEEK(cSVOPx_sv(lvalp->opval))); + } + + } + else + sv_catpvs(report, "(opval=null)"); + break; + } PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report)); }; return (int)rv; @@ -534,14 +534,14 @@ STATIC int S_ao(pTHX_ int toketype) { if (*PL_bufptr == '=') { - PL_bufptr++; - if (toketype == ANDAND) - pl_yylval.ival = OP_ANDASSIGN; - else if (toketype == OROR) - pl_yylval.ival = OP_ORASSIGN; - else if (toketype == DORDOR) - pl_yylval.ival = OP_DORASSIGN; - toketype = ASSIGNOP; + PL_bufptr++; + if (toketype == ANDAND) + pl_yylval.ival = OP_ANDASSIGN; + else if (toketype == OROR) + pl_yylval.ival = OP_ORASSIGN; + else if (toketype == DORDOR) + pl_yylval.ival = OP_DORASSIGN; + toketype = ASSIGNOP; } return REPORT(toketype); } @@ -571,36 +571,36 @@ S_no_op(pTHX_ const char *const what, char *s) PERL_ARGS_ASSERT_NO_OP; if (!s) - s = oldbp; + s = oldbp; else - PL_bufptr = s; + PL_bufptr = s; yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0); if (ckWARN_d(WARN_SYNTAX)) { - if (is_first) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\t(Missing semicolon on previous line?)\n"); + if (is_first) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing semicolon on previous line?)\n"); else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr, PL_bufend, UTF)) { - const char *t; - for (t = PL_oldoldbufptr; + const char *t; + for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':'); t += UTF ? UTF8SKIP(t) : 1) { - NOOP; - } - if (t < PL_bufptr && isSPACE(*t)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\t(Do you need to predeclare %" UTF8f "?)\n", - UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr)); - } - else { - assert(s >= oldbp); - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\t(Missing operator before %" UTF8f "?)\n", - UTF8fARG(UTF, s - oldbp, oldbp)); - } + NOOP; + } + if (t < PL_bufptr && isSPACE(*t)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Do you need to predeclare %" UTF8f "?)\n", + UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr)); + } + else { + assert(s >= oldbp); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing operator before %" UTF8f "?)\n", + UTF8fARG(UTF, s - oldbp, oldbp)); + } } PL_bufptr = oldbp; } @@ -622,38 +622,38 @@ S_missingterm(pTHX_ char *s, STRLEN len) bool uni = FALSE; SV *sv; if (s) { - char * const nl = (char *) my_memrchr(s, '\n', len); + char * const nl = (char *) my_memrchr(s, '\n', len); if (nl) { *nl = '\0'; len = nl - s; } - uni = UTF; + uni = UTF; } else if (PL_multi_close < 32) { - *tmpbuf = '^'; - tmpbuf[1] = (char)toCTRL(PL_multi_close); - tmpbuf[2] = '\0'; - s = tmpbuf; + *tmpbuf = '^'; + tmpbuf[1] = (char)toCTRL(PL_multi_close); + tmpbuf[2] = '\0'; + s = tmpbuf; len = 2; } else { - if (LIKELY(PL_multi_close < 256)) { - *tmpbuf = (char)PL_multi_close; - tmpbuf[1] = '\0'; + if (LIKELY(PL_multi_close < 256)) { + *tmpbuf = (char)PL_multi_close; + tmpbuf[1] = '\0'; len = 1; - } - else { + } + else { char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close); *end = '\0'; len = end - tmpbuf; - uni = TRUE; - } - s = tmpbuf; + uni = TRUE; + } + s = tmpbuf; } q = memchr(s, '"', len) ? '\'' : '"'; sv = sv_2mortal(newSVpvn(s, len)); if (uni) - SvUTF8_on(sv); + SvUTF8_on(sv); Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c" " anywhere before EOF", q, SVfARG(sv), q); } @@ -676,18 +676,18 @@ strip_return(SV *sv) /* outer loop optimized to do nothing if there are no CR-LFs */ while (s < e) { - if (*s++ == '\r' && *s == '\n') { - /* hit a CR-LF, need to copy the rest */ - char *d = s - 1; - *d++ = *s++; - while (s < e) { - if (*s == '\r' && s[1] == '\n') - s++; - *d++ = *s++; - } - SvCUR(sv) -= s - d; - return; - } + if (*s++ == '\r' && *s == '\n') { + /* hit a CR-LF, need to copy the rest */ + char *d = s - 1; + *d++ = *s++; + while (s < e) { + if (*s == '\r' && s[1] == '\n') + s++; + *d++ = *s++; + } + SvCUR(sv) -= s - d; + return; + } } } @@ -696,7 +696,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) { const I32 count = FILTER_READ(idx+1, sv, maxlen); if (count > 0 && !maxlen) - strip_return(sv); + strip_return(sv); return count; } #endif @@ -741,7 +741,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) yy_parser *parser, *oparser; if (flags && flags & ~LEX_START_FLAGS) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start"); /* create and initialise a parser */ @@ -781,10 +781,10 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) Newxz(parser->lex_shared, 1, LEXSHARED); if (line) { - STRLEN len; + STRLEN len; const U8* first_bad_char_loc; - s = SvPV_const(line, len); + s = SvPV_const(line, len); if ( SvUTF8(line) && UNLIKELY(! is_utf8_string_loc((U8 *) s, @@ -798,19 +798,19 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) NOT_REACHED; /* NOTREACHED */ } - parser->linestr = flags & LEX_START_COPIED - ? SvREFCNT_inc_simple_NN(line) - : newSVpvn_flags(s, len, SvUTF8(line)); - if (!rsfp) - sv_catpvs(parser->linestr, "\n;"); + parser->linestr = flags & LEX_START_COPIED + ? SvREFCNT_inc_simple_NN(line) + : newSVpvn_flags(s, len, SvUTF8(line)); + if (!rsfp) + sv_catpvs(parser->linestr, "\n;"); } else { - parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); + parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); } parser->oldoldbufptr = - parser->oldbufptr = - parser->bufptr = - parser->linestart = SvPVX(parser->linestr); + parser->oldbufptr = + parser->bufptr = + parser->linestart = SvPVX(parser->linestr); parser->bufend = parser->bufptr + SvCUR(parser->linestr); parser->last_lop = parser->last_uni = NULL; @@ -834,10 +834,10 @@ Perl_parser_free(pTHX_ const yy_parser *parser) SvREFCNT_dec(parser->linestr); if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP) - PerlIO_clearerr(parser->rsfp); + PerlIO_clearerr(parser->rsfp); else if (parser->rsfp && (!parser->old_parser || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp))) - PerlIO_close(parser->rsfp); + PerlIO_close(parser->rsfp); SvREFCNT_dec(parser->rsfp_filters); SvREFCNT_dec(parser->lex_stuff); SvREFCNT_dec(parser->lex_sub_repl); @@ -855,13 +855,13 @@ Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab) I32 nexttoke = parser->nexttoke; PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS; while (nexttoke--) { - if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff) - && parser->nextval[nexttoke].opval - && parser->nextval[nexttoke].opval->op_slabbed - && OpSLAB(parser->nextval[nexttoke].opval) == slab) { - op_free(parser->nextval[nexttoke].opval); - parser->nextval[nexttoke].opval = NULL; - } + if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff) + && parser->nextval[nexttoke].opval + && parser->nextval[nexttoke].opval->op_slabbed + && OpSLAB(parser->nextval[nexttoke].opval) == slab) { + op_free(parser->nextval[nexttoke].opval); + parser->nextval[nexttoke].opval = NULL; + } } } @@ -990,7 +990,7 @@ Perl_lex_grow_linestr(pTHX_ STRLEN len) linestr = PL_parser->linestr; buf = SvPVX(linestr); if (len <= SvLEN(linestr)) - return buf; + return buf; /* Is the lex_shared linestr SV the same as the current linestr SV? * Only in this case does re_eval_start need adjusting, since it @@ -1016,9 +1016,9 @@ Perl_lex_grow_linestr(pTHX_ STRLEN len) PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; PL_parser->linestart = buf + linestart_pos; if (PL_parser->last_uni) - PL_parser->last_uni = buf + last_uni_pos; + PL_parser->last_uni = buf + last_uni_pos; if (PL_parser->last_lop) - PL_parser->last_lop = buf + last_lop_pos; + PL_parser->last_lop = buf + last_lop_pos; if (current && PL_parser->lex_shared->re_eval_start) PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos; return buf; @@ -1054,69 +1054,69 @@ Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags) char *bufptr; PERL_ARGS_ASSERT_LEX_STUFF_PVN; if (flags & ~(LEX_STUFF_UTF8)) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn"); if (UTF) { - if (flags & LEX_STUFF_UTF8) { - goto plain_copy; - } else { - STRLEN highhalf = variant_under_utf8_count((U8 *) pv, + if (flags & LEX_STUFF_UTF8) { + goto plain_copy; + } else { + STRLEN highhalf = variant_under_utf8_count((U8 *) pv, (U8 *) pv + len); const char *p, *e = pv+len;; - if (!highhalf) - goto plain_copy; - lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf); - bufptr = PL_parser->bufptr; - Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char); - SvCUR_set(PL_parser->linestr, - SvCUR(PL_parser->linestr) + len+highhalf); - PL_parser->bufend += len+highhalf; - for (p = pv; p != e; p++) { + if (!highhalf) + goto plain_copy; + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char); + SvCUR_set(PL_parser->linestr, + SvCUR(PL_parser->linestr) + len+highhalf); + PL_parser->bufend += len+highhalf; + for (p = pv; p != e; p++) { append_utf8_from_native_byte(*p, (U8 **) &bufptr); - } - } + } + } } else { - if (flags & LEX_STUFF_UTF8) { - STRLEN highhalf = 0; - const char *p, *e = pv+len; - for (p = pv; p != e; p++) { - U8 c = (U8)*p; - if (UTF8_IS_ABOVE_LATIN1(c)) { - Perl_croak(aTHX_ "Lexing code attempted to stuff " - "non-Latin-1 character into Latin-1 input"); - } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) { - p++; - highhalf++; + if (flags & LEX_STUFF_UTF8) { + STRLEN highhalf = 0; + const char *p, *e = pv+len; + for (p = pv; p != e; p++) { + U8 c = (U8)*p; + if (UTF8_IS_ABOVE_LATIN1(c)) { + Perl_croak(aTHX_ "Lexing code attempted to stuff " + "non-Latin-1 character into Latin-1 input"); + } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) { + p++; + highhalf++; } else assert(UTF8_IS_INVARIANT(c)); - } - if (!highhalf) - goto plain_copy; - lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf); - bufptr = PL_parser->bufptr; - Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char); - SvCUR_set(PL_parser->linestr, - SvCUR(PL_parser->linestr) + len-highhalf); - PL_parser->bufend += len-highhalf; - p = pv; - while (p < e) { - if (UTF8_IS_INVARIANT(*p)) { - *bufptr++ = *p; + } + if (!highhalf) + goto plain_copy; + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char); + SvCUR_set(PL_parser->linestr, + SvCUR(PL_parser->linestr) + len-highhalf); + PL_parser->bufend += len-highhalf; + p = pv; + while (p < e) { + if (UTF8_IS_INVARIANT(*p)) { + *bufptr++ = *p; p++; - } - else { + } + else { assert(p < e -1 ); - *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); - p += 2; + *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); + p += 2; } - } - } else { - plain_copy: - lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len); - bufptr = PL_parser->bufptr; - Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char); - SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len); - PL_parser->bufend += len; - Copy(pv, bufptr, len, char); - } + } + } else { + plain_copy: + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char); + SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len); + PL_parser->bufend += len; + Copy(pv, bufptr, len, char); + } } } @@ -1176,7 +1176,7 @@ Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags) STRLEN len; PERL_ARGS_ASSERT_LEX_STUFF_SV; if (flags) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv"); pv = SvPV(sv, len); lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0)); } @@ -1203,12 +1203,12 @@ Perl_lex_unstuff(pTHX_ char *ptr) PERL_ARGS_ASSERT_LEX_UNSTUFF; buf = PL_parser->bufptr; if (ptr < buf) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); if (ptr == buf) - return; + return; bufend = PL_parser->bufend; if (ptr > bufend) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); unstuff_len = ptr - buf; Move(ptr, buf, bufend+1-ptr, char); SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len); @@ -1237,12 +1237,12 @@ Perl_lex_read_to(pTHX_ char *ptr) PERL_ARGS_ASSERT_LEX_READ_TO; s = PL_parser->bufptr; if (ptr < s || ptr > PL_parser->bufend) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to"); for (; s != ptr; s++) - if (*s == '\n') { - COPLINE_INC_WITH_HERELINES; - PL_parser->linestart = s+1; - } + if (*s == '\n') { + COPLINE_INC_WITH_HERELINES; + PL_parser->linestart = s+1; + } PL_parser->bufptr = ptr; } @@ -1274,20 +1274,20 @@ Perl_lex_discard_to(pTHX_ char *ptr) PERL_ARGS_ASSERT_LEX_DISCARD_TO; buf = SvPVX(PL_parser->linestr); if (ptr < buf) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); if (ptr == buf) - return; + return; if (ptr > PL_parser->bufptr) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); discard_len = ptr - buf; if (PL_parser->oldbufptr < ptr) - PL_parser->oldbufptr = ptr; + PL_parser->oldbufptr = ptr; if (PL_parser->oldoldbufptr < ptr) - PL_parser->oldoldbufptr = ptr; + PL_parser->oldoldbufptr = ptr; if (PL_parser->last_uni && PL_parser->last_uni < ptr) - PL_parser->last_uni = NULL; + PL_parser->last_uni = NULL; if (PL_parser->last_lop && PL_parser->last_lop < ptr) - PL_parser->last_lop = NULL; + PL_parser->last_lop = NULL; Move(ptr, buf, PL_parser->bufend+1-ptr, char); SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len); PL_parser->bufend -= discard_len; @@ -1295,9 +1295,9 @@ Perl_lex_discard_to(pTHX_ char *ptr) PL_parser->oldbufptr -= discard_len; PL_parser->oldoldbufptr -= discard_len; if (PL_parser->last_uni) - PL_parser->last_uni -= discard_len; + PL_parser->last_uni -= discard_len; if (PL_parser->last_lop) - PL_parser->last_lop -= discard_len; + PL_parser->last_lop -= discard_len; } void @@ -1357,64 +1357,64 @@ Perl_lex_next_chunk(pTHX_ U32 flags) bool got_some; if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM)) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); if (!(flags & LEX_NO_TERM) && PL_lex_inwhat) - return FALSE; + return FALSE; linestr = PL_parser->linestr; buf = SvPVX(linestr); if (!(flags & LEX_KEEP_PREVIOUS) && PL_parser->bufptr == PL_parser->bufend) { - old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0; - linestart_pos = 0; - if (PL_parser->last_uni != PL_parser->bufend) - PL_parser->last_uni = NULL; - if (PL_parser->last_lop != PL_parser->bufend) - PL_parser->last_lop = NULL; - last_uni_pos = last_lop_pos = 0; - *buf = 0; - SvCUR_set(linestr, 0); + old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0; + linestart_pos = 0; + if (PL_parser->last_uni != PL_parser->bufend) + PL_parser->last_uni = NULL; + if (PL_parser->last_lop != PL_parser->bufend) + PL_parser->last_lop = NULL; + last_uni_pos = last_lop_pos = 0; + *buf = 0; + SvCUR_set(linestr, 0); } else { - old_bufend_pos = PL_parser->bufend - buf; - bufptr_pos = PL_parser->bufptr - buf; - oldbufptr_pos = PL_parser->oldbufptr - buf; - oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; - linestart_pos = PL_parser->linestart - buf; - last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; - last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; + old_bufend_pos = PL_parser->bufend - buf; + bufptr_pos = PL_parser->bufptr - buf; + oldbufptr_pos = PL_parser->oldbufptr - buf; + oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; + linestart_pos = PL_parser->linestart - buf; + last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; + last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; } if (flags & LEX_FAKE_EOF) { - goto eof; + goto eof; } else if (!PL_parser->rsfp && !PL_parser->filtered) { - got_some = 0; + got_some = 0; } else if (filter_gets(linestr, old_bufend_pos)) { - got_some = 1; - got_some_for_debugger = 1; + got_some = 1; + got_some_for_debugger = 1; } else if (flags & LEX_NO_TERM) { - got_some = 0; + got_some = 0; } else { - if (!SvPOK(linestr)) /* can get undefined by filter_gets */ + if (!SvPOK(linestr)) /* can get undefined by filter_gets */ SvPVCLEAR(linestr); - eof: - /* End of real input. Close filehandle (unless it was STDIN), - * then add implicit termination. - */ - if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP) - PerlIO_clearerr(PL_parser->rsfp); - else if (PL_parser->rsfp) - (void)PerlIO_close(PL_parser->rsfp); - PL_parser->rsfp = NULL; - PL_parser->in_pod = PL_parser->filtered = 0; - if (!PL_in_eval && PL_minus_p) { - sv_catpvs(linestr, - /*{*/";}continue{print or die qq(-p destination: $!\\n);}"); - PL_minus_n = PL_minus_p = 0; - } else if (!PL_in_eval && PL_minus_n) { - sv_catpvs(linestr, /*{*/";}"); - PL_minus_n = 0; - } else - sv_catpvs(linestr, ";"); - got_some = 1; + eof: + /* End of real input. Close filehandle (unless it was STDIN), + * then add implicit termination. + */ + if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP) + PerlIO_clearerr(PL_parser->rsfp); + else if (PL_parser->rsfp) + (void)PerlIO_close(PL_parser->rsfp); + PL_parser->rsfp = NULL; + PL_parser->in_pod = PL_parser->filtered = 0; + if (!PL_in_eval && PL_minus_p) { + sv_catpvs(linestr, + /*{*/";}continue{print or die qq(-p destination: $!\\n);}"); + PL_minus_n = PL_minus_p = 0; + } else if (!PL_in_eval && PL_minus_n) { + sv_catpvs(linestr, /*{*/";}"); + PL_minus_n = 0; + } else + sv_catpvs(linestr, ";"); + got_some = 1; } buf = SvPVX(linestr); new_bufend_pos = SvCUR(linestr); @@ -1440,22 +1440,22 @@ Perl_lex_next_chunk(pTHX_ U32 flags) PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; PL_parser->linestart = buf + linestart_pos; if (PL_parser->last_uni) - PL_parser->last_uni = buf + last_uni_pos; + PL_parser->last_uni = buf + last_uni_pos; if (PL_parser->last_lop) - PL_parser->last_lop = buf + last_lop_pos; + PL_parser->last_lop = buf + last_lop_pos; if (PL_parser->preambling != NOLINE) { - CopLINE_set(PL_curcop, PL_parser->preambling + 1); - PL_parser->preambling = NOLINE; + CopLINE_set(PL_curcop, PL_parser->preambling + 1); + PL_parser->preambling = NOLINE; } if ( got_some_for_debugger && PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash) { - /* debugger active and we're not compiling the debugger code, - * so store the line into the debugger's array of lines - */ - update_debugger_info(NULL, buf+old_bufend_pos, - new_bufend_pos-old_bufend_pos); + /* debugger active and we're not compiling the debugger code, + * so store the line into the debugger's array of lines + */ + update_debugger_info(NULL, buf+old_bufend_pos, + new_bufend_pos-old_bufend_pos); } return got_some; } @@ -1484,47 +1484,47 @@ Perl_lex_peek_unichar(pTHX_ U32 flags) { char *s, *bufend; if (flags & ~(LEX_KEEP_PREVIOUS)) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar"); s = PL_parser->bufptr; bufend = PL_parser->bufend; if (UTF) { - U8 head; - I32 unichar; - STRLEN len, retlen; - if (s == bufend) { - if (!lex_next_chunk(flags)) - return -1; - s = PL_parser->bufptr; - bufend = PL_parser->bufend; - } - head = (U8)*s; - if (UTF8_IS_INVARIANT(head)) - return head; - if (UTF8_IS_START(head)) { - len = UTF8SKIP(&head); - while ((STRLEN)(bufend-s) < len) { - if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS)) - break; - s = PL_parser->bufptr; - bufend = PL_parser->bufend; - } - } - unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY); - if (retlen == (STRLEN)-1) { + U8 head; + I32 unichar; + STRLEN len, retlen; + if (s == bufend) { + if (!lex_next_chunk(flags)) + return -1; + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + } + head = (U8)*s; + if (UTF8_IS_INVARIANT(head)) + return head; + if (UTF8_IS_START(head)) { + len = UTF8SKIP(&head); + while ((STRLEN)(bufend-s) < len) { + if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS)) + break; + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + } + } + unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY); + if (retlen == (STRLEN)-1) { _force_out_malformed_utf8_message((U8 *) s, (U8 *) bufend, 0, 1 /* 1 means die */ ); NOT_REACHED; /* NOTREACHED */ - } - return unichar; + } + return unichar; } else { - if (s == bufend) { - if (!lex_next_chunk(flags)) - return -1; - s = PL_parser->bufptr; - } - return (U8)*s; + if (s == bufend) { + if (!lex_next_chunk(flags)) + return -1; + s = PL_parser->bufptr; + } + return (U8)*s; } } @@ -1553,15 +1553,15 @@ Perl_lex_read_unichar(pTHX_ U32 flags) { I32 c; if (flags & ~(LEX_KEEP_PREVIOUS)) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar"); c = lex_peek_unichar(flags); if (c != -1) { - if (c == '\n') - COPLINE_INC_WITH_HERELINES; - if (UTF) - PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr); - else - ++(PL_parser->bufptr); + if (c == '\n') + COPLINE_INC_WITH_HERELINES; + if (UTF) + PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr); + else + ++(PL_parser->bufptr); } return c; } @@ -1593,49 +1593,49 @@ Perl_lex_read_space(pTHX_ U32 flags) const bool can_incline = !(flags & LEX_NO_INCLINE); bool need_incline = 0; if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE)) - Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space"); + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space"); s = PL_parser->bufptr; bufend = PL_parser->bufend; while (1) { - char c = *s; - if (c == '#') { - do { - c = *++s; - } while (!(c == '\n' || (c == 0 && s == bufend))); - } else if (c == '\n') { - s++; - if (can_incline) { - PL_parser->linestart = s; - if (s == bufend) - need_incline = 1; - else - incline(s, bufend); - } - } else if (isSPACE(c)) { - s++; - } else if (c == 0 && s == bufend) { - bool got_more; - line_t l; - if (flags & LEX_NO_NEXT_CHUNK) - break; - PL_parser->bufptr = s; - l = CopLINE(PL_curcop); - CopLINE(PL_curcop) += PL_parser->herelines + 1; - got_more = lex_next_chunk(flags); - CopLINE_set(PL_curcop, l); - s = PL_parser->bufptr; - bufend = PL_parser->bufend; - if (!got_more) - break; - if (can_incline && need_incline && PL_parser->rsfp) { - incline(s, bufend); - need_incline = 0; - } - } else if (!c) { - s++; - } else { - break; - } + char c = *s; + if (c == '#') { + do { + c = *++s; + } while (!(c == '\n' || (c == 0 && s == bufend))); + } else if (c == '\n') { + s++; + if (can_incline) { + PL_parser->linestart = s; + if (s == bufend) + need_incline = 1; + else + incline(s, bufend); + } + } else if (isSPACE(c)) { + s++; + } else if (c == 0 && s == bufend) { + bool got_more; + line_t l; + if (flags & LEX_NO_NEXT_CHUNK) + break; + PL_parser->bufptr = s; + l = CopLINE(PL_curcop); + CopLINE(PL_curcop) += PL_parser->herelines + 1; + got_more = lex_next_chunk(flags); + CopLINE_set(PL_curcop, l); + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + if (!got_more) + break; + if (can_incline && need_incline && PL_parser->rsfp) { + incline(s, bufend); + need_incline = 0; + } + } else if (!c) { + s++; + } else { + break; + } } PL_parser->bufptr = s; } @@ -1676,75 +1676,75 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash) PERL_ARGS_ASSERT_VALIDATE_PROTO; if (!proto) - return TRUE; + return TRUE; p = SvPV(proto, len); origlen = len; for (; len--; p++) { - if (!isSPACE(*p)) { - if (must_be_last) - proto_after_greedy_proto = TRUE; - if (underscore) { - if (!memCHRs(";@%", *p)) - bad_proto_after_underscore = TRUE; - underscore = FALSE; - } - if (!memCHRs("$@%*;[]&\\_+", *p) || *p == '\0') { - bad_proto = TRUE; - } - else { - if (*p == '[') - in_brackets = TRUE; - else if (*p == ']') - in_brackets = FALSE; - else if ((*p == '@' || *p == '%') + if (!isSPACE(*p)) { + if (must_be_last) + proto_after_greedy_proto = TRUE; + if (underscore) { + if (!memCHRs(";@%", *p)) + bad_proto_after_underscore = TRUE; + underscore = FALSE; + } + if (!memCHRs("$@%*;[]&\\_+", *p) || *p == '\0') { + bad_proto = TRUE; + } + else { + if (*p == '[') + in_brackets = TRUE; + else if (*p == ']') + in_brackets = FALSE; + else if ((*p == '@' || *p == '%') && !after_slash && !in_brackets ) { - must_be_last = TRUE; - greedy_proto = *p; - } - else if (*p == '_') - underscore = TRUE; - } - if (*p == '\\') - after_slash = TRUE; - else - after_slash = FALSE; - } + must_be_last = TRUE; + greedy_proto = *p; + } + else if (*p == '_') + underscore = TRUE; + } + if (*p == '\\') + after_slash = TRUE; + else + after_slash = FALSE; + } } if (warn) { - SV *tmpsv = newSVpvs_flags("", SVs_TEMP); - p -= origlen; - p = SvUTF8(proto) - ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8), - origlen, UNI_DISPLAY_ISPRINT) - : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII); - - if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) { - SV *name2 = sv_2mortal(newSVsv(PL_curstname)); - sv_catpvs(name2, "::"); - sv_catsv(name2, (SV *)name); - name = name2; - } - - if (proto_after_greedy_proto) - Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), - "Prototype after '%c' for %" SVf " : %s", - greedy_proto, SVfARG(name), p); - if (in_brackets) - Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), - "Missing ']' in prototype for %" SVf " : %s", - SVfARG(name), p); - if (bad_proto) - Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), - "Illegal character in prototype for %" SVf " : %s", - SVfARG(name), p); - if (bad_proto_after_underscore) - Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), - "Illegal character after '_' in prototype for %" SVf " : %s", - SVfARG(name), p); + SV *tmpsv = newSVpvs_flags("", SVs_TEMP); + p -= origlen; + p = SvUTF8(proto) + ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8), + origlen, UNI_DISPLAY_ISPRINT) + : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII); + + if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) { + SV *name2 = sv_2mortal(newSVsv(PL_curstname)); + sv_catpvs(name2, "::"); + sv_catsv(name2, (SV *)name); + name = name2; + } + + if (proto_after_greedy_proto) + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "Prototype after '%c' for %" SVf " : %s", + greedy_proto, SVfARG(name), p); + if (in_brackets) + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "Missing ']' in prototype for %" SVf " : %s", + SVfARG(name), p); + if (bad_proto) + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "Illegal character in prototype for %" SVf " : %s", + SVfARG(name), p); + if (bad_proto_after_underscore) + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "Illegal character after '_' in prototype for %" SVf " : %s", + SVfARG(name), p); } return (! (proto_after_greedy_proto || bad_proto) ); @@ -1776,110 +1776,110 @@ S_incline(pTHX_ const char *s, const char *end) COPLINE_INC_WITH_HERELINES; if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL && s+1 == PL_bufend && *s == ';') { - /* fake newline in string eval */ - CopLINE_dec(PL_curcop); - return; + /* fake newline in string eval */ + CopLINE_dec(PL_curcop); + return; } if (*s++ != '#') - return; + return; while (SPACE_OR_TAB(*s)) - s++; + s++; if (memBEGINs(s, (STRLEN) (end - s), "line")) - s += sizeof("line") - 1; + s += sizeof("line") - 1; else - return; + return; if (SPACE_OR_TAB(*s)) - s++; + s++; else - return; + return; while (SPACE_OR_TAB(*s)) - s++; + s++; if (!isDIGIT(*s)) - return; + return; n = s; while (isDIGIT(*s)) - s++; + s++; if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0') - return; + return; while (SPACE_OR_TAB(*s)) - s++; + s++; if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) { - s++; - e = t + 1; + s++; + e = t + 1; } else { - t = s; - while (*t && !isSPACE(*t)) - t++; - e = t; + t = s; + while (*t && !isSPACE(*t)) + t++; + e = t; } while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') - e++; + e++; if (*e != '\n' && *e != '\0') - return; /* false alarm */ + return; /* false alarm */ if (!grok_atoUV(n, &uv, &e)) return; line_num = ((line_t)uv) - 1; if (t - s > 0) { - const STRLEN len = t - s; - - if (!PL_rsfp && !PL_parser->filtered) { - /* must copy *{"::_<(eval N)[oldfilename:L]"} - * to *{"::_ 0) { - AV * const av2 = GvAVn(gv2); - SV **svp = AvARRAY(av) + start; - Size_t l = line_num+1; - while (items-- && l < SSize_t_MAX && l == (line_t)l) - av_store(av2, (SSize_t)l++, SvREFCNT_inc(*svp++)); - } - } - } - - if (tmpbuf2 != smallbuf) Safefree(tmpbuf2); - } - } - CopFILE_free(PL_curcop); - CopFILE_setn(PL_curcop, s, len); + const STRLEN len = t - s; + + if (!PL_rsfp && !PL_parser->filtered) { + /* must copy *{"::_<(eval N)[oldfilename:L]"} + * to *{"::_ 0) { + AV * const av2 = GvAVn(gv2); + SV **svp = AvARRAY(av) + start; + Size_t l = line_num+1; + while (items-- && l < SSize_t_MAX && l == (line_t)l) + av_store(av2, (SSize_t)l++, SvREFCNT_inc(*svp++)); + } + } + } + + if (tmpbuf2 != smallbuf) Safefree(tmpbuf2); + } + } + CopFILE_free(PL_curcop); + CopFILE_setn(PL_curcop, s, len); } CopLINE_set(PL_curcop, line_num); } @@ -1889,23 +1889,23 @@ S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) { AV *av = CopFILEAVx(PL_curcop); if (av) { - SV * sv; - if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG); - else { - sv = *av_fetch(av, 0, 1); - SvUPGRADE(sv, SVt_PVMG); - } + SV * sv; + if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG); + else { + sv = *av_fetch(av, 0, 1); + SvUPGRADE(sv, SVt_PVMG); + } if (!SvPOK(sv)) SvPVCLEAR(sv); - if (orig_sv) - sv_catsv(sv, orig_sv); - else - sv_catpvn(sv, buf, len); - if (!SvIOK(sv)) { - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - } - if (PL_parser->preambling == NOLINE) - av_store(av, CopLINE(PL_curcop), sv); + if (orig_sv) + sv_catsv(sv, orig_sv); + else + sv_catpvn(sv, buf, len); + if (!SvIOK(sv)) { + (void)SvIOK_on(sv); + SvIV_set(sv, 0); + } + if (PL_parser->preambling == NOLINE) + av_store(av, CopLINE(PL_curcop), sv); } } @@ -1928,19 +1928,19 @@ Perl_skipspace_flags(pTHX_ char *s, U32 flags) { PERL_ARGS_ASSERT_SKIPSPACE_FLAGS; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s)) - s++; + while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s)) + s++; } else { - STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr); - PL_bufptr = s; - lex_read_space(flags | LEX_KEEP_PREVIOUS | - (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ? - LEX_NO_NEXT_CHUNK : 0)); - s = PL_bufptr; - PL_bufptr = SvPVX(PL_linestr) + bufptr_pos; - if (PL_linestart > PL_bufptr) - PL_bufptr = PL_linestart; - return s; + STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr); + PL_bufptr = s; + lex_read_space(flags | LEX_KEEP_PREVIOUS | + (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ? + LEX_NO_NEXT_CHUNK : 0)); + s = PL_bufptr; + PL_bufptr = SvPVX(PL_linestr) + bufptr_pos; + if (PL_linestart > PL_bufptr) + PL_bufptr = PL_linestart; + return s; } return s; } @@ -1960,18 +1960,18 @@ S_check_uni(pTHX) const char *s; if (PL_oldoldbufptr != PL_last_uni) - return; + return; while (isSPACE(*PL_last_uni)) - PL_last_uni++; + PL_last_uni++; s = PL_last_uni; while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-') - s += UTF ? UTF8SKIP(s) : 1; + s += UTF ? UTF8SKIP(s) : 1; if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s)) - return; + return; Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), - "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous", - UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni)); + "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous", + UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni)); } /* @@ -2003,18 +2003,18 @@ S_lop(pTHX_ I32 f, U8 x, char *s) PL_last_lop = PL_oldbufptr; PL_last_lop_op = (OPCODE)f; if (PL_nexttoke) - goto lstop; + goto lstop; PL_expect = x; if (*s == '(') - return REPORT(FUNC); + return REPORT(FUNC); s = skipspace(s); if (*s == '(') - return REPORT(FUNC); + return REPORT(FUNC); else { - lstop: - if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; - return REPORT(LSTOP); + lstop: + if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) + PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; + return REPORT(LSTOP); } } @@ -2033,7 +2033,7 @@ S_force_next(pTHX_ I32 type) #ifdef DEBUGGING if (DEBUG_T_TEST) { PerlIO_printf(Perl_debug_log, "### forced token:\n"); - tokereport(type, &NEXTVAL_NEXTTOKE); + tokereport(type, &NEXTVAL_NEXTTOKE); } #endif assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype)); @@ -2062,22 +2062,22 @@ S_postderef(pTHX_ int const funny, char const next) || funny == PERLY_STAR ); if (next == '*') { - PL_expect = XOPERATOR; - if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { - assert(PERLY_SNAIL == funny || PERLY_DOLLAR == funny || DOLSHARP == funny); - PL_lex_state = LEX_INTERPEND; - if (PERLY_SNAIL == funny) - force_next(POSTJOIN); - } - force_next(PERLY_STAR); - PL_bufptr+=2; + PL_expect = XOPERATOR; + if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { + assert(PERLY_SNAIL == funny || PERLY_DOLLAR == funny || DOLSHARP == funny); + PL_lex_state = LEX_INTERPEND; + if (PERLY_SNAIL == funny) + force_next(POSTJOIN); + } + force_next(PERLY_STAR); + PL_bufptr+=2; } else { - if (PERLY_SNAIL == funny && PL_lex_state == LEX_INTERPNORMAL - && !PL_lex_brackets) - PL_lex_dojoin = 2; - PL_expect = XOPERATOR; - PL_bufptr++; + if (PERLY_SNAIL == funny && PL_lex_state == LEX_INTERPNORMAL + && !PL_lex_brackets) + PL_lex_dojoin = 2; + PL_expect = XOPERATOR; + PL_bufptr++; } return funny; } @@ -2087,19 +2087,19 @@ Perl_yyunlex(pTHX) { int yyc = PL_parser->yychar; if (yyc != YYEMPTY) { - if (yyc) { - NEXTVAL_NEXTTOKE = PL_parser->yylval; - if (yyc == PERLY_BRACE_OPEN || yyc == HASHBRACK || yyc == PERLY_BRACKET_OPEN) { - PL_lex_allbrackets--; - PL_lex_brackets--; - yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16); - } else if (yyc == PERLY_PAREN_OPEN) { - PL_lex_allbrackets--; - yyc |= (2<<24); - } - force_next(yyc); - } - PL_parser->yychar = YYEMPTY; + if (yyc) { + NEXTVAL_NEXTTOKE = PL_parser->yylval; + if (yyc == PERLY_BRACE_OPEN || yyc == HASHBRACK || yyc == PERLY_BRACKET_OPEN) { + PL_lex_allbrackets--; + PL_lex_brackets--; + yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16); + } else if (yyc == PERLY_PAREN_OPEN) { + PL_lex_allbrackets--; + yyc |= (2<<24); + } + force_next(yyc); + } + PL_parser->yychar = YYEMPTY; } } @@ -2144,30 +2144,30 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || (allow_pack && *s == ':' && s[1] == ':') ) { - s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); - if (check_keyword) { - char *s2 = PL_tokenbuf; - STRLEN len2 = len; - if (allow_pack && memBEGINPs(s2, len, "CORE::")) { - s2 += sizeof("CORE::") - 1; + s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); + if (check_keyword) { + char *s2 = PL_tokenbuf; + STRLEN len2 = len; + if (allow_pack && memBEGINPs(s2, len, "CORE::")) { + s2 += sizeof("CORE::") - 1; len2 -= sizeof("CORE::") - 1; } - if (keyword(s2, len2, 0)) - return start; - } - if (token == METHOD) { - s = skipspace(s); - if (*s == '(') - PL_expect = XTERM; - else { - PL_expect = XOPERATOR; - } - } - NEXTVAL_NEXTTOKE.opval + if (keyword(s2, len2, 0)) + return start; + } + if (token == METHOD) { + s = skipspace(s); + if (*s == '(') + PL_expect = XTERM; + else { + PL_expect = XOPERATOR; + } + } + NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST,0, - S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); - NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; - force_next(token); + S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); + NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; + force_next(token); } return s; } @@ -2187,25 +2187,25 @@ S_force_ident(pTHX_ const char *s, int kind) PERL_ARGS_ASSERT_FORCE_IDENT; if (s[0]) { - const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */ + const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */ OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0)); - NEXTVAL_NEXTTOKE.opval = o; - force_next(BAREWORD); - if (kind) { - o->op_private = OPpCONST_ENTERED; - /* XXX see note in pp_entereval() for why we forgo typo - warnings if the symbol must be introduced in an eval. - GSAR 96-10-12 */ - gv_fetchpvn_flags(s, len, - (PL_in_eval ? GV_ADDMULTI - : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), - kind == PERLY_DOLLAR ? SVt_PV : - kind == PERLY_SNAIL ? SVt_PVAV : - kind == PERLY_PERCENT_SIGN ? SVt_PVHV : - SVt_PVGV - ); - } + NEXTVAL_NEXTTOKE.opval = o; + force_next(BAREWORD); + if (kind) { + o->op_private = OPpCONST_ENTERED; + /* XXX see note in pp_entereval() for why we forgo typo + warnings if the symbol must be introduced in an eval. + GSAR 96-10-12 */ + gv_fetchpvn_flags(s, len, + (PL_in_eval ? GV_ADDMULTI + : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), + kind == PERLY_DOLLAR ? SVt_PV : + kind == PERLY_SNAIL ? SVt_PVAV : + kind == PERLY_PERCENT_SIGN ? SVt_PVHV : + SVt_PVGV + ); + } } } @@ -2229,17 +2229,17 @@ Perl_str_to_version(pTHX_ SV *sv) PERL_ARGS_ASSERT_STR_TO_VERSION; while (start < end) { - STRLEN skip; - UV n; - if (utf) - n = utf8n_to_uvchr((U8*)start, len, &skip, 0); - else { - n = *(U8*)start; - skip = 1; - } - retval += ((NV)n)/nshift; - start += skip; - nshift *= 1000; + STRLEN skip; + UV n; + if (utf) + n = utf8n_to_uvchr((U8*)start, len, &skip, 0); + else { + n = *(U8*)start; + skip = 1; + } + retval += ((NV)n)/nshift; + start += skip; + nshift *= 1000; } return retval; } @@ -2264,24 +2264,24 @@ S_force_version(pTHX_ char *s, int guessing) d = s; if (*d == 'v') - d++; + d++; if (isDIGIT(*d)) { - while (isDIGIT(*d) || *d == '_' || *d == '.') - d++; + while (isDIGIT(*d) || *d == '_' || *d == '.') + d++; if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) { - SV *ver; + SV *ver; s = scan_num(s, &pl_yylval); version = pl_yylval.opval; - ver = cSVOPx(version)->op_sv; - if (SvPOK(ver) && !SvNIOK(ver)) { - SvUPGRADE(ver, SVt_PVNV); - SvNV_set(ver, str_to_version(ver)); - SvNOK_on(ver); /* hint that it is a version */ - } + ver = cSVOPx(version)->op_sv; + if (SvPOK(ver) && !SvNIOK(ver)) { + SvUPGRADE(ver, SVt_PVNV); + SvNV_set(ver, str_to_version(ver)); + SvNOK_on(ver); /* hint that it is a version */ + } + } + else if (guessing) { + return s; } - else if (guessing) { - return s; - } } /* NOTE: The parser sees the package name and the VERSION swapped */ @@ -2305,20 +2305,20 @@ S_force_strict_version(pTHX_ char *s) PERL_ARGS_ASSERT_FORCE_STRICT_VERSION; while (isSPACE(*s)) /* leading whitespace */ - s++; + s++; if (is_STRICT_VERSION(s,&errstr)) { - SV *ver = newSV(0); - s = (char *)scan_version(s, ver, 0); - version = newSVOP(OP_CONST, 0, ver); + SV *ver = newSV(0); + s = (char *)scan_version(s, ver, 0); + version = newSVOP(OP_CONST, 0, ver); } else if ((*s != ';' && *s != '{' && *s != '}' ) && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' ))) { - PL_bufptr = s; - if (errstr) - yyerror(errstr); /* version required */ - return s; + PL_bufptr = s; + if (errstr) + yyerror(errstr); /* version required */ + return s; } /* NOTE: The parser sees the package name and the VERSION swapped */ @@ -2349,25 +2349,25 @@ S_tokeq(pTHX_ SV *sv) assert (SvLEN(sv)); assert (!SvIsCOW(sv)); if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */ - goto finish; + goto finish; s = SvPVX(sv); send = SvEND(sv); /* This is relying on the SV being "well formed" with a trailing '\0' */ while (s < send && !(*s == '\\' && s[1] == '\\')) - s++; + s++; if (s == send) - goto finish; + goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv), - SVs_TEMP | SvUTF8(sv)); + pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv), + SVs_TEMP | SvUTF8(sv)); } while (s < send) { - if (*s == '\\') { - if (s + 1 < send && (s[1] == '\\')) - s++; /* all that, just for this */ - } - *d++ = *s++; + if (*s == '\\') { + if (s + 1 < send && (s[1] == '\\')) + s++; /* all that, just for this */ + } + *d++ = *s++; } *d = '\0'; SvCUR_set(sv, d - SvPVX_const(sv)); @@ -2411,25 +2411,25 @@ S_sublex_start(pTHX) const I32 op_type = pl_yylval.ival; if (op_type == OP_NULL) { - pl_yylval.opval = PL_lex_op; - PL_lex_op = NULL; - return THING; + pl_yylval.opval = PL_lex_op; + PL_lex_op = NULL; + return THING; } if (op_type == OP_CONST) { - SV *sv = PL_lex_stuff; - PL_lex_stuff = NULL; - sv = tokeq(sv); - - if (SvTYPE(sv) == SVt_PVIV) { - /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ - STRLEN len; - const char * const p = SvPV_const(sv, len); - SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv)); - SvREFCNT_dec(sv); - sv = nsv; - } + SV *sv = PL_lex_stuff; + PL_lex_stuff = NULL; + sv = tokeq(sv); + + if (SvTYPE(sv) == SVt_PVIV) { + /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ + STRLEN len; + const char * const p = SvPV_const(sv, len); + SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv)); + SvREFCNT_dec(sv); + sv = nsv; + } pl_yylval.opval = newSVOP(op_type, 0, sv); - return THING; + return THING; } PL_parser->lex_super_state = PL_lex_state; @@ -2441,12 +2441,12 @@ S_sublex_start(pTHX) PL_expect = XTERM; if (PL_lex_op) { - pl_yylval.opval = PL_lex_op; - PL_lex_op = NULL; - return PMFUNC; + pl_yylval.opval = PL_lex_op; + PL_lex_op = NULL; + return PMFUNC; } else - return FUNC; + return FUNC; } /* @@ -2478,10 +2478,10 @@ S_sublex_push(pTHX) SAVEI16(PL_lex_inwhat); if (is_heredoc) { - SAVECOPLINE(PL_curcop); - SAVEI32(PL_multi_end); - SAVEI32(PL_parser->herelines); - PL_parser->herelines = 0; + SAVECOPLINE(PL_curcop); + SAVEI32(PL_multi_end); + SAVEI32(PL_parser->herelines); + PL_parser->herelines = 0; } SAVEIV(PL_multi_close); SAVEPPTR(PL_bufptr); @@ -2518,7 +2518,7 @@ S_sublex_push(pTHX) SAVEGENERICSV(PL_parser->lex_sub_repl); PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart - = SvPVX(PL_linestr); + = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; SAVEFREESV(PL_linestr); @@ -2535,7 +2535,7 @@ S_sublex_push(pTHX) PL_lex_starts = 0; PL_lex_state = LEX_INTERPCONCAT; if (is_heredoc) - CopLINE_set(PL_curcop, (line_t)PL_multi_start); + CopLINE_set(PL_curcop, (line_t)PL_multi_start); PL_copline = NOLINE; Newxz(shared, 1, LEXSHARED); @@ -2545,9 +2545,9 @@ S_sublex_push(pTHX) PL_lex_inwhat = PL_parser->lex_sub_inwhat; if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS; if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) - PL_lex_inpat = PL_parser->lex_sub_op; + PL_lex_inpat = PL_parser->lex_sub_op; else - PL_lex_inpat = NULL; + PL_lex_inpat = NULL; PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING); PL_in_eval &= ~EVAL_RE_REPARSING; @@ -2564,70 +2564,70 @@ STATIC I32 S_sublex_done(pTHX) { if (!PL_lex_starts++) { - SV * const sv = newSVpvs(""); - if (SvUTF8(PL_linestr)) - SvUTF8_on(sv); - PL_expect = XOPERATOR; + SV * const sv = newSVpvs(""); + if (SvUTF8(PL_linestr)) + SvUTF8_on(sv); + PL_expect = XOPERATOR; pl_yylval.opval = newSVOP(OP_CONST, 0, sv); - return THING; + return THING; } if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */ - PL_lex_state = LEX_INTERPCASEMOD; - return yylex(); + PL_lex_state = LEX_INTERPCASEMOD; + return yylex(); } /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ assert(PL_lex_inwhat != OP_TRANSR); if (PL_lex_repl) { - assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS); - PL_linestr = PL_lex_repl; - PL_lex_inpat = 0; - PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); - PL_bufend += SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - PL_lex_dojoin = FALSE; - PL_lex_brackets = 0; - PL_lex_allbrackets = 0; - PL_lex_fakeeof = LEX_FAKEEOF_NEVER; - PL_lex_casemods = 0; - *PL_lex_casestack = '\0'; - PL_lex_starts = 0; - if (SvEVALED(PL_lex_repl)) { - PL_lex_state = LEX_INTERPNORMAL; - PL_lex_starts++; - /* we don't clear PL_lex_repl here, so that we can check later - whether this is an evalled subst; that means we rely on the - logic to ensure sublex_done() is called again only via the - branch (in yylex()) that clears PL_lex_repl, else we'll loop */ - } - else { - PL_lex_state = LEX_INTERPCONCAT; - PL_lex_repl = NULL; - } - if (SvTYPE(PL_linestr) >= SVt_PVNV) { - CopLINE(PL_curcop) += - ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines - + PL_parser->herelines; - PL_parser->herelines = 0; - } - return PERLY_SLASH; + assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS); + PL_linestr = PL_lex_repl; + PL_lex_inpat = 0; + PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); + PL_bufend += SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = NULL; + PL_lex_dojoin = FALSE; + PL_lex_brackets = 0; + PL_lex_allbrackets = 0; + PL_lex_fakeeof = LEX_FAKEEOF_NEVER; + PL_lex_casemods = 0; + *PL_lex_casestack = '\0'; + PL_lex_starts = 0; + if (SvEVALED(PL_lex_repl)) { + PL_lex_state = LEX_INTERPNORMAL; + PL_lex_starts++; + /* we don't clear PL_lex_repl here, so that we can check later + whether this is an evalled subst; that means we rely on the + logic to ensure sublex_done() is called again only via the + branch (in yylex()) that clears PL_lex_repl, else we'll loop */ + } + else { + PL_lex_state = LEX_INTERPCONCAT; + PL_lex_repl = NULL; + } + if (SvTYPE(PL_linestr) >= SVt_PVNV) { + CopLINE(PL_curcop) += + ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines + + PL_parser->herelines; + PL_parser->herelines = 0; + } + return PERLY_SLASH; } else { - const line_t l = CopLINE(PL_curcop); - LEAVE; + const line_t l = CopLINE(PL_curcop); + LEAVE; if (PL_parser->sub_error_count != PL_error_count) { if (PL_parser->sub_no_recover) { yyquit(); NOT_REACHED; } } - if (PL_multi_close == '<') - PL_parser->herelines += l - PL_multi_end; - PL_bufend = SvPVX(PL_linestr); - PL_bufend += SvCUR(PL_linestr); - PL_expect = XOPERATOR; - return SUBLEXEND; + if (PL_multi_close == '<') + PL_parser->herelines += l - PL_multi_end; + PL_bufend = SvPVX(PL_linestr); + PL_bufend += SvCUR(PL_linestr); + PL_expect = XOPERATOR; + return SUBLEXEND; } } @@ -2702,7 +2702,7 @@ S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const /* charnames doesn't work well if there have been errors found */ if (PL_error_count > 0) { - return NULL; + return NULL; } result = get_and_check_backslash_N_name(s, e, cBOOL(UTF), &error_msg); @@ -2811,7 +2811,7 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, if (! isCHARNAME_CONT(*s)) { goto bad_charname; } - if (*s == ' ' && *(s-1) == ' ') { + if (*s == ' ' && *(s-1) == ' ') { goto multi_spaces; } s++; @@ -2957,12 +2957,12 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...}) pass through: - all other \-char, including \N and \N{ apart from \N{ABC} + all other \-char, including \N and \N{ apart from \N{ABC} stops on: - @ and $ where it appears to be a var, but not for $ as tail anchor + @ and $ where it appears to be a var, but not for $ as tail anchor \l \L \u \U \Q \E - (?{ or (??{ + (?{ or (??{ In transliterations: characters are VERY literal, except for - not at the start or end @@ -2998,25 +2998,25 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s, The structure of the code is while (there's a character to process) { - handle transliteration ranges - skip regexp comments /(?#comment)/ and codes /(?{code})/ - skip #-initiated comments in //x patterns - check for embedded arrays - check for embedded scalars - if (backslash) { - deprecate \1 in substitution replacements - handle string-changing backslashes \l \U \Q \E, etc. - switch (what was escaped) { - handle \- in a transliteration (becomes a literal -) - if a pattern and not \N{, go treat as regular character - handle \132 (octal characters) - handle \x15 and \x{1234} (hex characters) - handle \N{name} (named characters, also \N{3,5} in a pattern) - handle \cV (control characters) - handle printf-style backslashes (\f, \r, \n, etc) - } (end switch) - continue - } (end if backslash) + handle transliteration ranges + skip regexp comments /(?#comment)/ and codes /(?{code})/ + skip #-initiated comments in //x patterns + check for embedded arrays + check for embedded scalars + if (backslash) { + deprecate \1 in substitution replacements + handle string-changing backslashes \l \U \Q \E, etc. + switch (what was escaped) { + handle \- in a transliteration (becomes a literal -) + if a pattern and not \N{, go treat as regular character + handle \132 (octal characters) + handle \x15 and \x{1234} (hex characters) + handle \N{name} (named characters, also \N{3,5} in a pattern) + handle \cV (control characters) + handle printf-style backslashes (\f, \r, \n, etc) + } (end switch) + continue + } (end if backslash) handle regular character } (end while character to read) @@ -3094,7 +3094,7 @@ S_scan_const(pTHX_ char *start) ) { /* get transliterations out of the way (they're most literal) */ - if (PL_lex_inwhat == OP_TRANS) { + if (PL_lex_inwhat == OP_TRANS) { /* But there isn't any special handling necessary unless there is a * range, so for most cases we just drop down and handle the value @@ -3118,7 +3118,7 @@ S_scan_const(pTHX_ char *start) * because each code point in it has to be processed here * individually to get its native translation */ - if (! dorange) { + if (! dorange) { /* Here, we don't think we're in a range. If the new character * is not a hyphen; or if it is a hyphen, but it's too close to @@ -3179,7 +3179,7 @@ S_scan_const(pTHX_ char *start) char * max_ptr; char * min_ptr; IV range_min; - IV range_max; /* last character in range */ + IV range_max; /* last character in range */ STRLEN grow; Size_t offset_to_min = 0; Size_t extras = 0; @@ -3266,8 +3266,8 @@ S_scan_const(pTHX_ char *start) * of them */ if (isPRINT_A(range_min) && isPRINT_A(range_max)) { Perl_croak(aTHX_ - "Invalid range \"%c-%c\" in transliteration operator", - (char)range_min, (char)range_max); + "Invalid range \"%c-%c\" in transliteration operator", + (char)range_min, (char)range_max); } #ifdef EBCDIC else if (convert_unicode) { @@ -3295,7 +3295,7 @@ S_scan_const(pTHX_ char *start) /* Here the range contains at least 3 code points */ - if (d_is_utf8) { + if (d_is_utf8) { /* If everything in the transliteration is below 256, we * can avoid special handling later. A translation table @@ -3307,7 +3307,7 @@ S_scan_const(pTHX_ char *start) * if we have to convert to/from Unicode values */ if ( has_above_latin1 #ifdef EBCDIC - && (range_min > 255 || ! convert_unicode) + && (range_min > 255 || ! convert_unicode) #endif ) { const STRLEN off = d - SvPVX(sv); @@ -3342,7 +3342,7 @@ S_scan_const(pTHX_ char *start) range_max = 255; } #endif - } + } /* Here we need to expand out the string to contain each * character in the range. Grow the output to handle this. @@ -3439,8 +3439,8 @@ S_scan_const(pTHX_ char *start) for (i = range_min; i <= range_max; i++) { *d++ = (char)LATIN1_TO_NATIVE((U8) i); } - } - } + } + } else #endif /* Always gets run for ASCII, and sometimes for EBCDIC. */ @@ -3475,8 +3475,8 @@ S_scan_const(pTHX_ char *start) * 'utf8_variant_count' on EBCDIC (it's already been * counted when originally parsed) */ *d++ = (char) range_max; - } - } + } + } #ifdef EBCDIC /* If the original range extended above 255, add in that @@ -3494,37 +3494,37 @@ S_scan_const(pTHX_ char *start) #endif range_done: - /* mark the range as done, and continue */ - didrange = TRUE; - dorange = FALSE; + /* mark the range as done, and continue */ + didrange = TRUE; + dorange = FALSE; #ifdef EBCDIC - non_portable_endpoint = 0; + non_portable_endpoint = 0; backslash_N = 0; #endif - continue; - } /* End of is a range */ + continue; + } /* End of is a range */ } /* End of transliteration. Joins main code after these else's */ - else if (*s == '[' && PL_lex_inpat && !in_charclass) { - char *s1 = s-1; - int esc = 0; - while (s1 >= start && *s1-- == '\\') - esc = !esc; - if (!esc) - in_charclass = TRUE; - } - else if (*s == ']' && PL_lex_inpat && in_charclass) { - char *s1 = s-1; - int esc = 0; - while (s1 >= start && *s1-- == '\\') - esc = !esc; - if (!esc) - in_charclass = FALSE; - } + else if (*s == '[' && PL_lex_inpat && !in_charclass) { + char *s1 = s-1; + int esc = 0; + while (s1 >= start && *s1-- == '\\') + esc = !esc; + if (!esc) + in_charclass = TRUE; + } + else if (*s == ']' && PL_lex_inpat && in_charclass) { + char *s1 = s-1; + int esc = 0; + while (s1 >= start && *s1-- == '\\') + esc = !esc; + if (!esc) + in_charclass = FALSE; + } /* skip for regexp comments /(?#comment)/, except for the last * char, which will be done separately. Stop on (?{..}) and * friends */ - else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) { - if (s[2] == '#') { + else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) { + if (s[2] == '#') { if (s_is_utf8) { PERL_UINT_FAST8_T len = UTF8SKIP(s); @@ -3538,129 +3538,129 @@ S_scan_const(pTHX_ char *start) else while (s+1 < send && *s != ')') { *d++ = *s++; } - } - else if (!PL_lex_casemods + } + else if (!PL_lex_casemods && ( s[2] == '{' /* This should match regcomp.c */ - || (s[2] == '?' && s[3] == '{'))) - { - break; - } - } + || (s[2] == '?' && s[3] == '{'))) + { + break; + } + } /* likewise skip #-initiated comments in //x patterns */ - else if (*s == '#' + else if (*s == '#' && PL_lex_inpat && !in_charclass && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) { - while (s < send && *s != '\n') - *d++ = *s++; - } + while (s < send && *s != '\n') + *d++ = *s++; + } /* no further processing of single-quoted regex */ - else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') - goto default_action; + else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') + goto default_action; /* check for embedded arrays * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) */ - else if (*s == '@' && s[1]) { - if (UTF + else if (*s == '@' && s[1]) { + if (UTF ? isIDFIRST_utf8_safe(s+1, send) : isWORDCHAR_A(s[1])) { - break; + break; } - if (memCHRs(":'{$", s[1])) - break; - if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) - break; /* in regexp, neither @+ nor @- are interpolated */ - } + if (memCHRs(":'{$", s[1])) + break; + if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) + break; /* in regexp, neither @+ nor @- are interpolated */ + } /* check for embedded scalars. only stop if we're sure it's a * variable. */ - else if (*s == '$') { - if (!PL_lex_inpat) /* not a regexp, so $ must be var */ - break; - if (s + 1 < send && !memCHRs("()| \r\n\t", s[1])) { - if (s[1] == '\\') { - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Possible unintended interpolation of $\\ in regex"); - } - break; /* in regexp, $ might be tail anchor */ + else if (*s == '$') { + if (!PL_lex_inpat) /* not a regexp, so $ must be var */ + break; + if (s + 1 < send && !memCHRs("()| \r\n\t", s[1])) { + if (s[1] == '\\') { + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Possible unintended interpolation of $\\ in regex"); + } + break; /* in regexp, $ might be tail anchor */ } - } + } - /* End of else if chain - OP_TRANS rejoin rest */ + /* End of else if chain - OP_TRANS rejoin rest */ if (UNLIKELY(s >= send)) { assert(s == send); break; } - /* backslashes */ - if (*s == '\\' && s+1 < send) { - char* bslash = s; /* point to beginning \ */ - char* rbrace; /* point to ending '}' */ + /* backslashes */ + if (*s == '\\' && s+1 < send) { + char* bslash = s; /* point to beginning \ */ + char* rbrace; /* point to ending '}' */ char* e; /* 1 past the meat (non-blanks) before the brace */ - s++; + s++; - /* warn on \1 - \9 in substitution replacements, but note that \11 - * is an octal; and \19 is \1 followed by '9' */ - if (PL_lex_inwhat == OP_SUBST + /* warn on \1 - \9 in substitution replacements, but note that \11 + * is an octal; and \19 is \1 followed by '9' */ + if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) - { - /* diag_listed_as: \%d better written as $%d */ - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); + { + /* diag_listed_as: \%d better written as $%d */ + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); + s = bslash; + *s = '$'; + break; + } + + /* string-change backslash escapes */ + if (PL_lex_inwhat != OP_TRANS && *s && memCHRs("lLuUEQF", *s)) { s = bslash; - *s = '$'; - break; - } - - /* string-change backslash escapes */ - if (PL_lex_inwhat != OP_TRANS && *s && memCHRs("lLuUEQF", *s)) { - s = bslash; - break; - } - /* In a pattern, process \N, but skip any other backslash escapes. - * This is because we don't want to translate an escape sequence - * into a meta symbol and have the regex compiler use the meta - * symbol meaning, e.g. \x{2E} would be confused with a dot. But - * in spite of this, we do have to process \N here while the proper - * charnames handler is in scope. See bugs #56444 and #62056. + break; + } + /* In a pattern, process \N, but skip any other backslash escapes. + * This is because we don't want to translate an escape sequence + * into a meta symbol and have the regex compiler use the meta + * symbol meaning, e.g. \x{2E} would be confused with a dot. But + * in spite of this, we do have to process \N here while the proper + * charnames handler is in scope. See bugs #56444 and #62056. * - * There is a complication because \N in a pattern may also stand - * for 'match a non-nl', and not mean a charname, in which case its - * processing should be deferred to the regex compiler. To be a - * charname it must be followed immediately by a '{', and not look - * like \N followed by a curly quantifier, i.e., not something like - * \N{3,}. regcurly returns a boolean indicating if it is a legal - * quantifier */ - else if (PL_lex_inpat - && (*s != 'N' - || s[1] != '{' - || regcurly(s + 1, send, NULL))) - { - *d++ = '\\'; - goto default_action; - } - - switch (*s) { - default: - { - if ((isALPHANUMERIC(*s))) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Unrecognized escape \\%c passed through", - *s); - /* default action is to copy the quoted character */ - goto default_action; - } - - /* eg. \132 indicates the octal constant 0132 */ - case '0': case '1': case '2': case '3': - case '4': case '5': case '6': case '7': - { + * There is a complication because \N in a pattern may also stand + * for 'match a non-nl', and not mean a charname, in which case its + * processing should be deferred to the regex compiler. To be a + * charname it must be followed immediately by a '{', and not look + * like \N followed by a curly quantifier, i.e., not something like + * \N{3,}. regcurly returns a boolean indicating if it is a legal + * quantifier */ + else if (PL_lex_inpat + && (*s != 'N' + || s[1] != '{' + || regcurly(s + 1, send, NULL))) + { + *d++ = '\\'; + goto default_action; + } + + switch (*s) { + default: + { + if ((isALPHANUMERIC(*s))) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Unrecognized escape \\%c passed through", + *s); + /* default action is to copy the quoted character */ + goto default_action; + } + + /* eg. \132 indicates the octal constant 0132 */ + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + { I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT; STRLEN len = 3; @@ -3674,53 +3674,53 @@ S_scan_const(pTHX_ char *start) Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", form_alien_digit_msg(8, len, s, send, UTF, FALSE)); } - } - goto NUM_ESCAPE_INSERT; + } + goto NUM_ESCAPE_INSERT; - /* eg. \o{24} indicates the octal constant \024 */ - case 'o': - { - const char* error; + /* eg. \o{24} indicates the octal constant \024 */ + case 'o': + { + const char* error; - if (! grok_bslash_o(&s, send, + if (! grok_bslash_o(&s, send, &uv, &error, NULL, FALSE, /* Not strict */ FALSE, /* No illegal cp's */ UTF)) { - yyerror(error); - uv = 0; /* drop through to ensure range ends are set */ - } - goto NUM_ESCAPE_INSERT; - } - - /* eg. \x24 indicates the hex constant 0x24 */ - case 'x': - { - const char* error; - - if (! grok_bslash_x(&s, send, + yyerror(error); + uv = 0; /* drop through to ensure range ends are set */ + } + goto NUM_ESCAPE_INSERT; + } + + /* eg. \x24 indicates the hex constant 0x24 */ + case 'x': + { + const char* error; + + if (! grok_bslash_x(&s, send, &uv, &error, NULL, FALSE, /* Not strict */ FALSE, /* No illegal cp's */ UTF)) { - yyerror(error); - uv = 0; /* drop through to ensure range ends are set */ - } - } + yyerror(error); + uv = 0; /* drop through to ensure range ends are set */ + } + } - NUM_ESCAPE_INSERT: - /* Insert oct or hex escaped character. */ + NUM_ESCAPE_INSERT: + /* Insert oct or hex escaped character. */ - /* Here uv is the ordinal of the next character being added */ - if (UVCHR_IS_INVARIANT(uv)) { - *d++ = (char) uv; - } - else { - if (!d_is_utf8 && uv > 255) { + /* Here uv is the ordinal of the next character being added */ + if (UVCHR_IS_INVARIANT(uv)) { + *d++ = (char) uv; + } + else { + if (!d_is_utf8 && uv > 255) { /* Here, 'uv' won't fit unless we convert to UTF-8. * If we've only seen invariants so far, all we have to @@ -3752,10 +3752,10 @@ S_scan_const(pTHX_ char *start) } if (! d_is_utf8) { - *d++ = (char)uv; + *d++ = (char)uv; utf8_variant_count++; } - else { + else { /* Usually, there will already be enough room in 'sv' * since such escapes are likely longer than any UTF-8 * sequence they can end up as. This isn't the case on @@ -3772,18 +3772,18 @@ S_scan_const(pTHX_ char *start) d = SvCUR(sv) + SvGROW(sv, needed); } - d = (char*) uvchr_to_utf8_flags((U8*)d, uv, + d = (char*) uvchr_to_utf8_flags((U8*)d, uv, (ckWARN(WARN_PORTABLE)) ? UNICODE_WARN_PERL_EXTENDED : 0); - } - } + } + } #ifdef EBCDIC non_portable_endpoint++; #endif - continue; + continue; - case 'N': + case 'N': /* In a non-pattern \N must be like \N{U+0041}, or it can be a * named character, like \N{LATIN SMALL LETTER A}, or a named * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND @@ -3806,8 +3806,8 @@ S_scan_const(pTHX_ char *start) * right now, while preserving the fact that it was a named * character, so that the regex compiler knows this. * - * The structure of this section of code (besides checking for - * errors and upgrading to utf8) is: + * The structure of this section of code (besides checking for + * errors and upgrading to utf8) is: * If the named character is of the form \N{U+...}, pass it * through if a pattern; otherwise convert the code point * to utf8 @@ -3818,29 +3818,29 @@ S_scan_const(pTHX_ char *start) * only done if the code point requires it to be representable. * * Here, 's' points to the 'N'; the test below is guaranteed to - * succeed if we are being called on a pattern, as we already + * succeed if we are being called on a pattern, as we already * know from a test above that the next character is a '{'. A * non-pattern \N must mean 'named character', which requires * braces */ - s++; - if (*s != '{') { - yyerror("Missing braces on \\N{}"); + s++; + if (*s != '{') { + yyerror("Missing braces on \\N{}"); *d++ = '\0'; - continue; - } - s++; - - /* If there is no matching '}', it is an error. */ - if (! (rbrace = (char *) memchr(s, '}', send - s))) { - if (! PL_lex_inpat) { - yyerror("Missing right brace on \\N{}"); - } else { - yyerror("Missing right brace on \\N{} or unescaped left brace after \\N"); - } + continue; + } + s++; + + /* If there is no matching '}', it is an error. */ + if (! (rbrace = (char *) memchr(s, '}', send - s))) { + if (! PL_lex_inpat) { + yyerror("Missing right brace on \\N{}"); + } else { + yyerror("Missing right brace on \\N{} or unescaped left brace after \\N"); + } yyquit(); /* Have exhausted the input. */ - } + } - /* Here it looks like a named character */ + /* Here it looks like a named character */ while (s < rbrace && isBLANK(*s)) { s++; } @@ -3850,9 +3850,9 @@ S_scan_const(pTHX_ char *start) e--; } - if (*s == 'U' && s[1] == '+') { /* \N{U+...} */ - s += 2; /* Skip to next char after the 'U+' */ - if (PL_lex_inpat) { + if (*s == 'U' && s[1] == '+') { /* \N{U+...} */ + s += 2; /* Skip to next char after the 'U+' */ + if (PL_lex_inpat) { /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */ /* Check the syntax. */ @@ -3878,12 +3878,12 @@ S_scan_const(pTHX_ char *start) * +1 is to include the '}' */ Copy(bslash, d, rbrace - bslash + 1, char); d += rbrace - bslash + 1; - } - else { /* Not a pattern: convert the hex to string */ + } + else { /* Not a pattern: convert the hex to string */ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_SILENT_ILLDIGIT - | PERL_SCAN_SILENT_OVERFLOW - | PERL_SCAN_DISALLOW_PREFIX; + | PERL_SCAN_SILENT_ILLDIGIT + | PERL_SCAN_SILENT_OVERFLOW + | PERL_SCAN_DISALLOW_PREFIX; STRLEN len = e - s; uv = grok_hex(s, &len, &flags, NULL); @@ -3905,15 +3905,15 @@ S_scan_const(pTHX_ char *start) * tr/// doesn't care about Unicode rules, so no need * there to upgrade to UTF-8 for small enough code * points */ - if (! d_is_utf8 && ( uv > 0xFF + if (! d_is_utf8 && ( uv > 0xFF || PL_lex_inwhat != OP_TRANS)) { - /* See Note on sizing above. */ + /* See Note on sizing above. */ const STRLEN extra = OFFUNISKIP(uv) + (send - rbrace) + 1; - SvCUR_set(sv, d - SvPVX_const(sv)); - SvPOK_on(sv); - *d = '\0'; + SvCUR_set(sv, d - SvPVX_const(sv)); + SvPOK_on(sv); + *d = '\0'; if (utf8_variant_count == 0) { SvUTF8_on(sv); @@ -3927,23 +3927,23 @@ S_scan_const(pTHX_ char *start) d = SvPVX(sv) + SvCUR(sv); } - d_is_utf8 = TRUE; + d_is_utf8 = TRUE; has_above_latin1 = TRUE; - } + } /* Add the (Unicode) code point to the output. */ - if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) { - *d++ = (char) LATIN1_TO_NATIVE(uv); - } - else { + if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) { + *d++ = (char) LATIN1_TO_NATIVE(uv); + } + else { d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, (ckWARN(WARN_PORTABLE)) ? UNICODE_WARN_PERL_EXTENDED : 0); } - } - } - else /* Here is \N{NAME} but not \N{U+...}. */ + } + } + else /* Here is \N{NAME} but not \N{U+...}. */ if (! (res = get_and_check_backslash_N_name_wrapper(s, e))) { /* Failed. We should die eventually, but for now use a NUL to keep parsing */ @@ -3954,20 +3954,20 @@ S_scan_const(pTHX_ char *start) const char *str = SvPV_const(res, len); if (PL_lex_inpat) { - if (! len) { /* The name resolved to an empty string */ + if (! len) { /* The name resolved to an empty string */ const char empty_N[] = "\\N{_}"; Copy(empty_N, d, sizeof(empty_N) - 1, char); d += sizeof(empty_N) - 1; - } - else { - /* In order to not lose information for the regex - * compiler, pass the result in the specially made - * syntax: \N{U+c1.c2.c3...}, where c1 etc. are - * the code points in hex of each character - * returned by charnames */ + } + else { + /* In order to not lose information for the regex + * compiler, pass the result in the specially made + * syntax: \N{U+c1.c2.c3...}, where c1 etc. are + * the code points in hex of each character + * returned by charnames */ - const char *str_end = str + len; - const STRLEN off = d - SvPVX_const(sv); + const char *str_end = str + len; + const STRLEN off = d - SvPVX_const(sv); if (! SvUTF8(res)) { /* For the non-UTF-8 case, we can determine the @@ -4060,13 +4060,13 @@ S_scan_const(pTHX_ char *start) Copy(hex_string, d, output_length, char); d += output_length; } - } + } - *d++ = '}'; /* Done. Add the trailing brace */ - } - } - else { /* Here, not in a pattern. Convert the name to a - * string. */ + *d++ = '}'; /* Done. Add the trailing brace */ + } + } + else { /* Here, not in a pattern. Convert the name to a + * string. */ if (PL_lex_inwhat == OP_TRANS) { str = SvPV_const(res, len); @@ -4099,13 +4099,13 @@ S_scan_const(pTHX_ char *start) /* Upgrade destination to be utf8 if this new * component is */ - if (! d_is_utf8 && SvUTF8(res)) { - /* See Note on sizing above. */ + if (! d_is_utf8 && SvUTF8(res)) { + /* See Note on sizing above. */ const STRLEN extra = len + (send - s) + 1; - SvCUR_set(sv, d - SvPVX_const(sv)); - SvPOK_on(sv); - *d = '\0'; + SvCUR_set(sv, d - SvPVX_const(sv)); + SvPOK_on(sv); + *d = '\0'; if (utf8_variant_count == 0) { SvUTF8_on(sv); @@ -4113,83 +4113,83 @@ S_scan_const(pTHX_ char *start) } else { sv_utf8_upgrade_flags_grow(sv, - SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, - extra); + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + extra); d = SvPVX(sv) + SvCUR(sv); } - d_is_utf8 = TRUE; - } else if (len > (STRLEN)(e - s + 4)) { /* +4 is for \N{} */ + d_is_utf8 = TRUE; + } else if (len > (STRLEN)(e - s + 4)) { /* +4 is for \N{} */ - /* See Note on sizing above. (NOTE: SvCUR() is not - * set correctly here). */ + /* See Note on sizing above. (NOTE: SvCUR() is not + * set correctly here). */ const STRLEN extra = len + (send - rbrace) + 1; - const STRLEN off = d - SvPVX_const(sv); - d = off + SvGROW(sv, off + extra); - } - Copy(str, d, len, char); - d += len; - } + const STRLEN off = d - SvPVX_const(sv); + d = off + SvGROW(sv, off + extra); + } + Copy(str, d, len, char); + d += len; + } - SvREFCNT_dec(res); + SvREFCNT_dec(res); - } /* End \N{NAME} */ + } /* End \N{NAME} */ end_backslash_N: #ifdef EBCDIC backslash_N++; /* \N{} is defined to be Unicode */ #endif - s = rbrace + 1; /* Point to just after the '}' */ - continue; + s = rbrace + 1; /* Point to just after the '}' */ + continue; - /* \c is a control character */ - case 'c': - s++; - if (s < send) { + /* \c is a control character */ + case 'c': + s++; + if (s < send) { const char * message; - if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) { + if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) { yyerror(message); yyquit(); /* Have always immediately croaked on errors in this */ } - d++; - } - else { - yyerror("Missing control char name in \\c"); - yyquit(); /* Are at end of input, no sense continuing */ - } + d++; + } + else { + yyerror("Missing control char name in \\c"); + yyquit(); /* Are at end of input, no sense continuing */ + } #ifdef EBCDIC non_portable_endpoint++; #endif break; - /* printf-style backslashes, formfeeds, newlines, etc */ - case 'b': - *d++ = '\b'; - break; - case 'n': - *d++ = '\n'; - break; - case 'r': - *d++ = '\r'; - break; - case 'f': - *d++ = '\f'; - break; - case 't': - *d++ = '\t'; - break; - case 'e': - *d++ = ESC_NATIVE; - break; - case 'a': - *d++ = '\a'; - break; - } /* end switch */ - - s++; - continue; - } /* end if (backslash) */ + /* printf-style backslashes, formfeeds, newlines, etc */ + case 'b': + *d++ = '\b'; + break; + case 'n': + *d++ = '\n'; + break; + case 'r': + *d++ = '\r'; + break; + case 'f': + *d++ = '\f'; + break; + case 't': + *d++ = '\t'; + break; + case 'e': + *d++ = ESC_NATIVE; + break; + case 'a': + *d++ = '\a'; + break; + } /* end switch */ + + s++; + continue; + } /* end if (backslash) */ default_action: /* Just copy the input to the output, though we may have to convert @@ -4198,17 +4198,17 @@ S_scan_const(pTHX_ char *start) * If the input has the same representation in UTF-8 as not, it will be * a single byte, and we don't care about UTF8ness; just copy the byte */ if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) { - *d++ = *s++; + *d++ = *s++; } else if (! s_is_utf8 && ! d_is_utf8) { /* If neither source nor output is UTF-8, is also a single byte, * just copy it; but this byte counts should we later have to * convert to UTF-8 */ - *d++ = *s++; + *d++ = *s++; utf8_variant_count++; } else if (s_is_utf8 && d_is_utf8) { /* Both UTF-8, can just copy */ - const STRLEN len = UTF8SKIP(s); + const STRLEN len = UTF8SKIP(s); /* We expect the source to have already been checked for * malformedness */ @@ -4245,12 +4245,12 @@ S_scan_const(pTHX_ char *start) const STRLEN off = d - SvPVX(sv); const STRLEN extra = 2 + (send - s - 1) + 1; if (off + extra > SvLEN(sv)) { - d = off + SvGROW(sv, off + extra); - } + d = off + SvGROW(sv, off + extra); + } *d++ = UTF8_EIGHT_BIT_HI(*s); *d++ = UTF8_EIGHT_BIT_LO(*s); s++; - } + } } /* while loop to process each character */ { @@ -4281,47 +4281,47 @@ S_scan_const(pTHX_ char *start) SvPOK_on(sv); if (d_is_utf8) { - SvUTF8_on(sv); + SvUTF8_on(sv); } /* shrink the sv if we allocated more than we used */ if (SvCUR(sv) + 5 < SvLEN(sv)) { - SvPV_shrink_to_cur(sv); + SvPV_shrink_to_cur(sv); } /* return the substring (via pl_yylval) only if we parsed anything */ if (s > start) { - char *s2 = start; - for (; s2 < s; s2++) { - if (*s2 == '\n') - COPLINE_INC_WITH_HERELINES; - } - SvREFCNT_inc_simple_void_NN(sv); - if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING )) + char *s2 = start; + for (; s2 < s; s2++) { + if (*s2 == '\n') + COPLINE_INC_WITH_HERELINES; + } + SvREFCNT_inc_simple_void_NN(sv); + if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING )) && ! PL_parser->lex_re_reparsing) { - const char *const key = PL_lex_inpat ? "qr" : "q"; - const STRLEN keylen = PL_lex_inpat ? 2 : 1; - const char *type; - STRLEN typelen; - - if (PL_lex_inwhat == OP_TRANS) { - type = "tr"; - typelen = 2; - } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) { - type = "s"; - typelen = 1; - } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') { - type = "q"; - typelen = 1; - } else { - type = "qq"; - typelen = 2; - } - - sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL, - type, typelen, NULL); - } + const char *const key = PL_lex_inpat ? "qr" : "q"; + const STRLEN keylen = PL_lex_inpat ? 2 : 1; + const char *type; + STRLEN typelen; + + if (PL_lex_inwhat == OP_TRANS) { + type = "tr"; + typelen = 2; + } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) { + type = "s"; + typelen = 1; + } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') { + type = "q"; + typelen = 1; + } else { + type = "qq"; + typelen = 2; + } + + sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL, + type, typelen, NULL); + } pl_yylval.opval = newSVOP(OP_CONST, 0, sv); } LEAVE_with_name("scan_const"); @@ -4356,134 +4356,134 @@ S_intuit_more(pTHX_ char *s, char *e) PERL_ARGS_ASSERT_INTUIT_MORE; if (PL_lex_brackets) - return TRUE; + return TRUE; if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) - return TRUE; + return TRUE; if (*s == '-' && s[1] == '>' && FEATURE_POSTDEREF_QQ_IS_ENABLED && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*'))) - ||(s[2] == '@' && memCHRs("*[{",s[3])) )) - return TRUE; + ||(s[2] == '@' && memCHRs("*[{",s[3])) )) + return TRUE; if (*s != '{' && *s != '[') - return FALSE; + return FALSE; PL_parser->sub_no_recover = TRUE; if (!PL_lex_inpat) - return TRUE; + return TRUE; /* In a pattern, so maybe we have {n,m}. */ if (*s == '{') { - if (regcurly(s, e, NULL)) { - return FALSE; - } - return TRUE; + if (regcurly(s, e, NULL)) { + return FALSE; + } + return TRUE; } /* On the other hand, maybe we have a character class */ s++; if (*s == ']' || *s == '^') - return FALSE; + return FALSE; else { /* this is terrifying, and it works */ - int weight; - char seen[256]; - const char * const send = (char *) memchr(s, ']', e - s); - unsigned char un_char, last_un_char; - char tmpbuf[sizeof PL_tokenbuf * 4]; - - if (!send) /* has to be an expression */ - return TRUE; - weight = 2; /* let's weigh the evidence */ - - if (*s == '$') - weight -= 3; - else if (isDIGIT(*s)) { - if (s[1] != ']') { - if (isDIGIT(s[1]) && s[2] == ']') - weight -= 10; - } - else - weight -= 100; - } - Zero(seen,256,char); - un_char = 255; - for (; s < send; s++) { - last_un_char = un_char; - un_char = (unsigned char)*s; - switch (*s) { - case '@': - case '&': - case '$': - weight -= seen[un_char] * 10; - if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) { - int len; - scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); - len = (int)strlen(tmpbuf); - if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, - UTF ? SVf_UTF8 : 0, SVt_PV)) - weight -= 100; - else - weight -= 10; - } - else if (*s == '$' - && s[1] - && memCHRs("[#!%*<>()-=",s[1])) - { - if (/*{*/ memCHRs("])} =",s[2])) - weight -= 10; - else - weight -= 1; - } - break; - case '\\': - un_char = 254; - if (s[1]) { - if (memCHRs("wds]",s[1])) - weight += 100; - else if (seen[(U8)'\''] || seen[(U8)'"']) - weight += 1; - else if (memCHRs("rnftbxcav",s[1])) - weight += 40; - else if (isDIGIT(s[1])) { - weight += 40; - while (s[1] && isDIGIT(s[1])) - s++; - } - } - else - weight += 100; - break; - case '-': - if (s[1] == '\\') - weight += 50; - if (memCHRs("aA01! ",last_un_char)) - weight += 30; - if (memCHRs("zZ79~",s[1])) - weight += 30; - if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) - weight -= 5; /* cope with negative subscript */ - break; - default: - if (!isWORDCHAR(last_un_char) - && !(last_un_char == '$' || last_un_char == '@' - || last_un_char == '&') - && isALPHA(*s) && s[1] && isALPHA(s[1])) { - char *d = s; - while (isALPHA(*s)) - s++; - if (keyword(d, s - d, 0)) - weight -= 150; - } - if (un_char == last_un_char + 1) - weight += 5; - weight -= seen[un_char]; - break; - } - seen[un_char]++; - } - if (weight >= 0) /* probably a character class */ - return FALSE; - } + int weight; + char seen[256]; + const char * const send = (char *) memchr(s, ']', e - s); + unsigned char un_char, last_un_char; + char tmpbuf[sizeof PL_tokenbuf * 4]; + + if (!send) /* has to be an expression */ + return TRUE; + weight = 2; /* let's weigh the evidence */ + + if (*s == '$') + weight -= 3; + else if (isDIGIT(*s)) { + if (s[1] != ']') { + if (isDIGIT(s[1]) && s[2] == ']') + weight -= 10; + } + else + weight -= 100; + } + Zero(seen,256,char); + un_char = 255; + for (; s < send; s++) { + last_un_char = un_char; + un_char = (unsigned char)*s; + switch (*s) { + case '@': + case '&': + case '$': + weight -= seen[un_char] * 10; + if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) { + int len; + scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); + len = (int)strlen(tmpbuf); + if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, + UTF ? SVf_UTF8 : 0, SVt_PV)) + weight -= 100; + else + weight -= 10; + } + else if (*s == '$' + && s[1] + && memCHRs("[#!%*<>()-=",s[1])) + { + if (/*{*/ memCHRs("])} =",s[2])) + weight -= 10; + else + weight -= 1; + } + break; + case '\\': + un_char = 254; + if (s[1]) { + if (memCHRs("wds]",s[1])) + weight += 100; + else if (seen[(U8)'\''] || seen[(U8)'"']) + weight += 1; + else if (memCHRs("rnftbxcav",s[1])) + weight += 40; + else if (isDIGIT(s[1])) { + weight += 40; + while (s[1] && isDIGIT(s[1])) + s++; + } + } + else + weight += 100; + break; + case '-': + if (s[1] == '\\') + weight += 50; + if (memCHRs("aA01! ",last_un_char)) + weight += 30; + if (memCHRs("zZ79~",s[1])) + weight += 30; + if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) + weight -= 5; /* cope with negative subscript */ + break; + default: + if (!isWORDCHAR(last_un_char) + && !(last_un_char == '$' || last_un_char == '@' + || last_un_char == '&') + && isALPHA(*s) && s[1] && isALPHA(s[1])) { + char *d = s; + while (isALPHA(*s)) + s++; + if (keyword(d, s - d, 0)) + weight -= 150; + } + if (un_char == last_un_char + 1) + weight += 5; + weight -= seen[un_char]; + break; + } + seen[un_char]++; + } + if (weight >= 0) /* probably a character class */ + return FALSE; + } return TRUE; } @@ -4516,12 +4516,12 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) char tmpbuf[sizeof PL_tokenbuf]; STRLEN len; GV* indirgv; - /* Mustn't actually add anything to a symbol table. - But also don't want to "initialise" any placeholder - constants that might already be there into full - blown PVGVs with attached PVCV. */ + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ GV * const gv = - ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL; + ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL; PERL_ARGS_ASSERT_INTUIT_METHOD; @@ -4529,28 +4529,28 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) return 0; if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv)) - return 0; + return 0; if (cv && SvPOK(cv)) { - const char *proto = CvPROTO(cv); - if (proto) { - while (*proto && (isSPACE(*proto) || *proto == ';')) - proto++; - if (*proto == '*') - return 0; - } + const char *proto = CvPROTO(cv); + if (proto) { + while (*proto && (isSPACE(*proto) || *proto == ';')) + proto++; + if (*proto == '*') + return 0; + } } if (*start == '$') { SSize_t start_off = start - SvPVX(PL_linestr); - if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY + if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) - return 0; + return 0; /* this could be $# */ if (isSPACE(*s)) s = skipspace(s); - PL_bufptr = SvPVX(PL_linestr) + start_off; - PL_expect = XREF; - return *s == '(' ? FUNCMETH : METHOD; + PL_bufptr = SvPVX(PL_linestr) + start_off; + PL_expect = XREF; + return *s == '(' ? FUNCMETH : METHOD; } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); @@ -4560,31 +4560,31 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) */ if (!keyword(tmpbuf, len, 0)) { - if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { - len -= 2; - tmpbuf[len] = '\0'; - goto bare_package; - } - indirgv = gv_fetchpvn_flags(tmpbuf, len, - GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ), - SVt_PVCV); - if (indirgv && SvTYPE(indirgv) != SVt_NULL - && (!isGV(indirgv) || GvCVu(indirgv))) - return 0; - /* filehandle or package name makes it a method */ - if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { - s = skipspace(s); - if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') - return 0; /* no assumptions -- "=>" quotes bareword */ + if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { + len -= 2; + tmpbuf[len] = '\0'; + goto bare_package; + } + indirgv = gv_fetchpvn_flags(tmpbuf, len, + GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ), + SVt_PVCV); + if (indirgv && SvTYPE(indirgv) != SVt_NULL + && (!isGV(indirgv) || GvCVu(indirgv))) + return 0; + /* filehandle or package name makes it a method */ + if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { + s = skipspace(s); + if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') + return 0; /* no assumptions -- "=>" quotes bareword */ bare_package: NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, - S_newSV_maybe_utf8(aTHX_ tmpbuf, len)); - NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE; - PL_expect = XTERM; - force_next(BAREWORD); - PL_bufptr = s; - return *s == '(' ? FUNCMETH : METHOD; - } + S_newSV_maybe_utf8(aTHX_ tmpbuf, len)); + NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE; + PL_expect = XTERM; + force_next(BAREWORD); + PL_bufptr = s; + return *s == '(' ? FUNCMETH : METHOD; + } } return 0; } @@ -4610,64 +4610,64 @@ SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { if (!funcp) - return NULL; + return NULL; if (!PL_parser) - return NULL; + return NULL; if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) - Perl_croak(aTHX_ "Source filters apply only to byte streams"); + Perl_croak(aTHX_ "Source filters apply only to byte streams"); if (!PL_rsfp_filters) - PL_rsfp_filters = newAV(); + PL_rsfp_filters = newAV(); if (!datasv) - datasv = newSV(0); + datasv = newSV(0); SvUPGRADE(datasv, SVt_PVIO); IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - FPTR2DPTR(void *, IoANY(datasv)), - SvPV_nolen(datasv))); + FPTR2DPTR(void *, IoANY(datasv)), + SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; if ( - !PL_parser->filtered + !PL_parser->filtered && PL_parser->lex_flags & LEX_EVALBYTES && PL_bufptr < PL_bufend ) { - const char *s = PL_bufptr; - while (s < PL_bufend) { - if (*s == '\n') { - SV *linestr = PL_parser->linestr; - char *buf = SvPVX(linestr); - STRLEN const bufptr_pos = PL_parser->bufptr - buf; - STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf; - STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf; - STRLEN const linestart_pos = PL_parser->linestart - buf; - STRLEN const last_uni_pos = - PL_parser->last_uni ? PL_parser->last_uni - buf : 0; - STRLEN const last_lop_pos = - PL_parser->last_lop ? PL_parser->last_lop - buf : 0; - av_push(PL_rsfp_filters, linestr); - PL_parser->linestr = - newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr)); - buf = SvPVX(PL_parser->linestr); - PL_parser->bufend = buf + SvCUR(PL_parser->linestr); - PL_parser->bufptr = buf + bufptr_pos; - PL_parser->oldbufptr = buf + oldbufptr_pos; - PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; - PL_parser->linestart = buf + linestart_pos; - if (PL_parser->last_uni) - PL_parser->last_uni = buf + last_uni_pos; - if (PL_parser->last_lop) - PL_parser->last_lop = buf + last_lop_pos; - SvLEN_set(linestr, SvCUR(linestr)); - SvCUR_set(linestr, s - SvPVX(linestr)); - PL_parser->filtered = 1; - break; - } - s++; - } + const char *s = PL_bufptr; + while (s < PL_bufend) { + if (*s == '\n') { + SV *linestr = PL_parser->linestr; + char *buf = SvPVX(linestr); + STRLEN const bufptr_pos = PL_parser->bufptr - buf; + STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf; + STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf; + STRLEN const linestart_pos = PL_parser->linestart - buf; + STRLEN const last_uni_pos = + PL_parser->last_uni ? PL_parser->last_uni - buf : 0; + STRLEN const last_lop_pos = + PL_parser->last_lop ? PL_parser->last_lop - buf : 0; + av_push(PL_rsfp_filters, linestr); + PL_parser->linestr = + newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr)); + buf = SvPVX(PL_parser->linestr); + PL_parser->bufend = buf + SvCUR(PL_parser->linestr); + PL_parser->bufptr = buf + bufptr_pos; + PL_parser->oldbufptr = buf + oldbufptr_pos; + PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; + PL_parser->linestart = buf + linestart_pos; + if (PL_parser->last_uni) + PL_parser->last_uni = buf + last_uni_pos; + if (PL_parser->last_lop) + PL_parser->last_lop = buf + last_lop_pos; + SvLEN_set(linestr, SvCUR(linestr)); + SvCUR_set(linestr, s - SvPVX(linestr)); + PL_parser->filtered = 1; + break; + } + s++; + } } return(datasv); } @@ -4683,14 +4683,14 @@ Perl_filter_del(pTHX_ filter_t funcp) #ifdef DEBUGGING DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", - FPTR2DPTR(void*, funcp))); + FPTR2DPTR(void*, funcp))); #endif if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) - return; + return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { - sv_free(av_pop(PL_rsfp_filters)); + sv_free(av_pop(PL_rsfp_filters)); return; } @@ -4715,76 +4715,76 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) PERL_ARGS_ASSERT_FILTER_READ; if (!PL_parser || !PL_rsfp_filters) - return -1; + return -1; if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ - /* Provide a default input filter to make life easy. */ - /* Note that we append to the line. This is handy. */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "filter_read %d: from rsfp\n", idx)); - if (correct_length) { - /* Want a block */ - int len ; - const int old_len = SvCUR(buf_sv); - - /* ensure buf_sv is large enough */ - SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ; - if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, - correct_length)) <= 0) { - if (PerlIO_error(PL_rsfp)) - return -1; /* error */ - else - return 0 ; /* end of file */ - } - SvCUR_set(buf_sv, old_len + len) ; - SvPVX(buf_sv)[old_len + len] = '\0'; - } else { - /* Want a line */ + /* Provide a default input filter to make life easy. */ + /* Note that we append to the line. This is handy. */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "filter_read %d: from rsfp\n", idx)); + if (correct_length) { + /* Want a block */ + int len ; + const int old_len = SvCUR(buf_sv); + + /* ensure buf_sv is large enough */ + SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ; + if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, + correct_length)) <= 0) { + if (PerlIO_error(PL_rsfp)) + return -1; /* error */ + else + return 0 ; /* end of file */ + } + SvCUR_set(buf_sv, old_len + len) ; + SvPVX(buf_sv)[old_len + len] = '\0'; + } else { + /* Want a line */ if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { - if (PerlIO_error(PL_rsfp)) - return -1; /* error */ - else - return 0 ; /* end of file */ - } - } - return SvCUR(buf_sv); + if (PerlIO_error(PL_rsfp)) + return -1; /* error */ + else + return 0 ; /* end of file */ + } + } + return SvCUR(buf_sv); } /* Skip this filter slot if filter has been deleted */ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { - DEBUG_P(PerlIO_printf(Perl_debug_log, - "filter_read %d: skipped (filter deleted)\n", - idx)); - return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "filter_read %d: skipped (filter deleted)\n", + idx)); + return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */ } if (SvTYPE(datasv) != SVt_PVIO) { - if (correct_length) { - /* Want a block */ - const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv); - if (!remainder) return 0; /* eof */ - if (correct_length > remainder) correct_length = remainder; - sv_catpvn(buf_sv, SvEND(datasv), correct_length); - SvCUR_set(datasv, SvCUR(datasv) + correct_length); - } else { - /* Want a line */ - const char *s = SvEND(datasv); - const char *send = SvPVX(datasv) + SvLEN(datasv); - while (s < send) { - if (*s == '\n') { - s++; - break; - } - s++; - } - if (s == send) return 0; /* eof */ - sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv)); - SvCUR_set(datasv, s-SvPVX(datasv)); - } - return SvCUR(buf_sv); + if (correct_length) { + /* Want a block */ + const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv); + if (!remainder) return 0; /* eof */ + if (correct_length > remainder) correct_length = remainder; + sv_catpvn(buf_sv, SvEND(datasv), correct_length); + SvCUR_set(datasv, SvCUR(datasv) + correct_length); + } else { + /* Want a line */ + const char *s = SvEND(datasv); + const char *send = SvPVX(datasv) + SvLEN(datasv); + while (s < send) { + if (*s == '\n') { + s++; + break; + } + s++; + } + if (s == send) return 0; /* eof */ + sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv)); + SvCUR_set(datasv, s-SvPVX(datasv)); + } + return SvCUR(buf_sv); } /* Get function pointer hidden within datasv */ funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "filter_read %d: via function %p (%s)\n", - idx, (void*)datasv, SvPV_nolen_const(datasv))); + "filter_read %d: via function %p (%s)\n", + idx, (void*)datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -4802,16 +4802,16 @@ S_filter_gets(pTHX_ SV *sv, STRLEN append) #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { - filter_add(S_cr_textfilter,NULL); + filter_add(S_cr_textfilter,NULL); } #endif if (PL_rsfp_filters) { - if (!append) + if (!append) SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else - return NULL ; + return NULL ; } else return (sv_gets(sv, PL_rsfp, append)); @@ -4839,9 +4839,9 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) /* use constant CLASS => 'MyClass' */ gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV); if (gv && GvCV(gv)) { - SV * const sv = cv_const_sv(GvCV(gv)); - if (sv) - return gv_stashsv(sv, 0); + SV * const sv = cv_const_sv(GvCV(gv)); + if (sv) + return gv_stashsv(sv, 0); } return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0); @@ -4853,36 +4853,36 @@ S_tokenize_use(pTHX_ int is_use, char *s) { PERL_ARGS_ASSERT_TOKENIZE_USE; if (PL_expect != XSTATE) - /* diag_listed_as: "use" not allowed in expression */ - yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", - is_use ? "use" : "no")); + /* diag_listed_as: "use" not allowed in expression */ + yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", + is_use ? "use" : "no")); PL_expect = XTERM; s = skipspace(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s, TRUE); - if (*s == ';' || *s == '}' - || (s = skipspace(s), (*s == ';' || *s == '}'))) { - NEXTVAL_NEXTTOKE.opval = NULL; - force_next(BAREWORD); - } - else if (*s == 'v') { - s = force_word(s,BAREWORD,FALSE,TRUE); - s = force_version(s, FALSE); - } + s = force_version(s, TRUE); + if (*s == ';' || *s == '}' + || (s = skipspace(s), (*s == ';' || *s == '}'))) { + NEXTVAL_NEXTTOKE.opval = NULL; + force_next(BAREWORD); + } + else if (*s == 'v') { + s = force_word(s,BAREWORD,FALSE,TRUE); + s = force_version(s, FALSE); + } } else { - s = force_word(s,BAREWORD,FALSE,TRUE); - s = force_version(s, FALSE); + s = force_word(s,BAREWORD,FALSE,TRUE); + s = force_version(s, FALSE); } pl_yylval.ival = is_use; return s; } #ifdef DEBUGGING static const char* const exp_name[] = - { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", - "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF", - "SIGVAR", "TERMORDORDOR" - }; + { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", + "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF", + "SIGVAR", "TERMORDORDOR" + }; #endif #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l) @@ -4904,7 +4904,7 @@ S_check_scalar_slice(pTHX_ char *s) PL_bufend, UTF)) { - return; + return; } while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || (*s && memCHRs(" \t$#+-'\"", *s))) @@ -4912,7 +4912,7 @@ S_check_scalar_slice(pTHX_ char *s) s += UTF ? UTF8SKIP(s) : 1; } if (*s == '}' || *s == ']') - pl_yylval.ival = OPpSLICEWARNING; + pl_yylval.ival = OPpSLICEWARNING; } #define lex_token_boundary() S_lex_token_boundary(aTHX) @@ -4931,7 +4931,7 @@ S_vcs_conflict_marker(pTHX_ char *s) PL_bufptr = s; yyerror("Version control conflict marker"); while (s < PL_bufend && *s != '\n') - s++; + s++; return s; } @@ -8736,66 +8736,66 @@ yyl_try(pTHX_ char *s) goto retry; case 0: - if ((!PL_rsfp || PL_lex_inwhat) - && (!PL_parser->filtered || s+1 < PL_bufend)) { - PL_last_uni = 0; - PL_last_lop = 0; - if (PL_lex_brackets + if ((!PL_rsfp || PL_lex_inwhat) + && (!PL_parser->filtered || s+1 < PL_bufend)) { + PL_last_uni = 0; + PL_last_lop = 0; + if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) { - yyerror((const char *) - (PL_lex_formbrack - ? "Format not terminated" - : "Missing right curly or square bracket")); - } + yyerror((const char *) + (PL_lex_formbrack + ? "Format not terminated" + : "Missing right curly or square bracket")); + } DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); }); - TOKEN(0); - } - if (s++ < PL_bufend) - goto retry; /* ignore stray nulls */ - PL_last_uni = 0; - PL_last_lop = 0; - if (!PL_in_eval && !PL_preambled) { - PL_preambled = TRUE; - if (PL_perldb) { - /* Generate a string of Perl code to load the debugger. - * If PERL5DB is set, it will return the contents of that, - * otherwise a compile-time require of perl5db.pl. */ - - const char * const pdb = PerlEnv_getenv("PERL5DB"); - - if (pdb) { - sv_setpv(PL_linestr, pdb); - sv_catpvs(PL_linestr,";"); - } else { - SETERRNO(0,SS_NORMAL); - sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };"); - } - PL_parser->preambling = CopLINE(PL_curcop); - } else + TOKEN(0); + } + if (s++ < PL_bufend) + goto retry; /* ignore stray nulls */ + PL_last_uni = 0; + PL_last_lop = 0; + if (!PL_in_eval && !PL_preambled) { + PL_preambled = TRUE; + if (PL_perldb) { + /* Generate a string of Perl code to load the debugger. + * If PERL5DB is set, it will return the contents of that, + * otherwise a compile-time require of perl5db.pl. */ + + const char * const pdb = PerlEnv_getenv("PERL5DB"); + + if (pdb) { + sv_setpv(PL_linestr, pdb); + sv_catpvs(PL_linestr,";"); + } else { + SETERRNO(0,SS_NORMAL); + sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };"); + } + PL_parser->preambling = CopLINE(PL_curcop); + } else SvPVCLEAR(PL_linestr); - if (PL_preambleav) { - SV **svp = AvARRAY(PL_preambleav); - SV **const end = svp + AvFILLp(PL_preambleav); - while(svp <= end) { - sv_catsv(PL_linestr, *svp); - ++svp; - sv_catpvs(PL_linestr, ";"); - } - sv_free(MUTABLE_SV(PL_preambleav)); - PL_preambleav = NULL; - } - if (PL_minus_E) - sv_catpvs(PL_linestr, - "use feature ':" STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) "';"); - if (PL_minus_n || PL_minus_p) { - sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/); - if (PL_minus_l) - sv_catpvs(PL_linestr,"chomp;"); - if (PL_minus_a) { - if (PL_minus_F) { + if (PL_preambleav) { + SV **svp = AvARRAY(PL_preambleav); + SV **const end = svp + AvFILLp(PL_preambleav); + while(svp <= end) { + sv_catsv(PL_linestr, *svp); + ++svp; + sv_catpvs(PL_linestr, ";"); + } + sv_free(MUTABLE_SV(PL_preambleav)); + PL_preambleav = NULL; + } + if (PL_minus_E) + sv_catpvs(PL_linestr, + "use feature ':" STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) "';"); + if (PL_minus_n || PL_minus_p) { + sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/); + if (PL_minus_l) + sv_catpvs(PL_linestr,"chomp;"); + if (PL_minus_a) { + if (PL_minus_F) { if ( ( *PL_splitstr == '/' || *PL_splitstr == '\'' || *PL_splitstr == '"') @@ -8803,50 +8803,50 @@ yyl_try(pTHX_ char *s) { /* strchr is ok, because -F pattern can't contain * embeddded NULs */ - Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); + Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); } - else { - /* "q\0${splitstr}\0" is legal perl. Yes, even NUL - bytes can be used as quoting characters. :-) */ - const char *splits = PL_splitstr; - sv_catpvs(PL_linestr, "our @F=split(q\0"); - do { - /* Need to \ \s */ - if (*splits == '\\') - sv_catpvn(PL_linestr, splits, 1); - sv_catpvn(PL_linestr, splits, 1); - } while (*splits++); - /* This loop will embed the trailing NUL of - PL_linestr as the last thing it does before - terminating. */ - sv_catpvs(PL_linestr, ");"); - } - } - else - sv_catpvs(PL_linestr,"our @F=split(' ');"); - } - } - sv_catpvs(PL_linestr, "\n"); - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash) - update_debugger_info(PL_linestr, NULL, 0); - goto retry; - } + else { + /* "q\0${splitstr}\0" is legal perl. Yes, even NUL + bytes can be used as quoting characters. :-) */ + const char *splits = PL_splitstr; + sv_catpvs(PL_linestr, "our @F=split(q\0"); + do { + /* Need to \ \s */ + if (*splits == '\\') + sv_catpvn(PL_linestr, splits, 1); + sv_catpvn(PL_linestr, splits, 1); + } while (*splits++); + /* This loop will embed the trailing NUL of + PL_linestr as the last thing it does before + terminating. */ + sv_catpvs(PL_linestr, ");"); + } + } + else + sv_catpvs(PL_linestr,"our @F=split(' ');"); + } + } + sv_catpvs(PL_linestr, "\n"); + PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = NULL; + if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); + goto retry; + } if ((tok = yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s)) != YYL_RETRY) return tok; goto retry_bufptr; case '\r': #ifdef PERL_STRICT_CR - Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); - Perl_croak(aTHX_ + Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); + Perl_croak(aTHX_ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case '\v': - s++; - goto retry; + s++; + goto retry; case '#': case '\n': { @@ -8879,12 +8879,12 @@ yyl_try(pTHX_ char *s) return yyl_tilde(aTHX_ s); case ',': - if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) - TOKEN(0); - s++; - OPERATOR(PERLY_COMMA); + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) + TOKEN(0); + s++; + OPERATOR(PERLY_COMMA); case ':': - if (s[1] == ':') + if (s[1] == ':') return yyl_just_a_word(aTHX_ s, 0, 0, no_code); return yyl_colon(aTHX_ s + 1); @@ -8892,12 +8892,12 @@ yyl_try(pTHX_ char *s) return yyl_leftparen(aTHX_ s + 1); case ';': - if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) - TOKEN(0); - CLINE; - s++; - PL_expect = XSTATE; - TOKEN(PERLY_SEMICOLON); + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) + TOKEN(0); + CLINE; + s++; + PL_expect = XSTATE; + TOKEN(PERLY_SEMICOLON); case ')': return yyl_rightparen(aTHX_ s); @@ -8909,8 +8909,8 @@ yyl_try(pTHX_ char *s) return yyl_leftcurly(aTHX_ s + 1, 0); case '}': - if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) - TOKEN(0); + if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) + TOKEN(0); return yyl_rightcurly(aTHX_ s, 0); case '&': @@ -8927,35 +8927,35 @@ yyl_try(pTHX_ char *s) goto retry; } - s++; - { - const char tmp = *s++; - if (tmp == '=') { - if (!PL_lex_allbrackets + s++; + { + const char tmp = *s++; + if (tmp == '=') { + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { - s -= 2; - TOKEN(0); - } - ChEop(OP_EQ); - } - if (tmp == '>') { - if (!PL_lex_allbrackets + s -= 2; + TOKEN(0); + } + ChEop(OP_EQ); + } + if (tmp == '>') { + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) { - s -= 2; - TOKEN(0); - } - OPERATOR(PERLY_COMMA); - } - if (tmp == '~') - PMop(OP_MATCH); - if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) - && memCHRs("+-*/%.^&|<",tmp)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Reversed %c= operator",(int)tmp); - s--; - if (PL_expect == XSTATE + s -= 2; + TOKEN(0); + } + OPERATOR(PERLY_COMMA); + } + if (tmp == '~') + PMop(OP_MATCH); + if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) + && memCHRs("+-*/%.^&|<",tmp)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Reversed %c= operator",(int)tmp); + s--; + if (PL_expect == XSTATE && isALPHA(tmp) && (s == PL_linestart+1 || s[-2] == '\n') ) { @@ -8984,31 +8984,31 @@ yyl_try(pTHX_ char *s) PL_parser->in_pod = 1; goto retry; } - } - if (PL_expect == XBLOCK) { - const char *t = s; + } + if (PL_expect == XBLOCK) { + const char *t = s; #ifdef PERL_STRICT_CR - while (SPACE_OR_TAB(*t)) + while (SPACE_OR_TAB(*t)) #else - while (SPACE_OR_TAB(*t) || *t == '\r') + while (SPACE_OR_TAB(*t) || *t == '\r') #endif - t++; - if (*t == '\n' || *t == '#') { - ENTER_with_name("lex_format"); - SAVEI8(PL_parser->form_lex_state); - SAVEI32(PL_lex_formbrack); - PL_parser->form_lex_state = PL_lex_state; - PL_lex_formbrack = PL_lex_brackets + 1; + t++; + if (*t == '\n' || *t == '#') { + ENTER_with_name("lex_format"); + SAVEI8(PL_parser->form_lex_state); + SAVEI32(PL_lex_formbrack); + PL_parser->form_lex_state = PL_lex_state; + PL_lex_formbrack = PL_lex_brackets + 1; PL_parser->sub_error_count = PL_error_count; return yyl_leftcurly(aTHX_ s, 1); - } - } - if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { - s--; - TOKEN(0); - } - pl_yylval.ival = 0; - OPERATOR(ASSIGNOP); + } + } + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { + s--; + TOKEN(0); + } + pl_yylval.ival = 0; + OPERATOR(ASSIGNOP); case '!': return yyl_bang(aTHX_ s + 1); @@ -9041,67 +9041,67 @@ yyl_try(pTHX_ char *s) return yyl_slash(aTHX_ s); case '?': /* conditional */ - s++; - if (!PL_lex_allbrackets + s++; + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) { - s--; - TOKEN(0); - } - PL_lex_allbrackets++; - OPERATOR(PERLY_QUESTION_MARK); + s--; + TOKEN(0); + } + PL_lex_allbrackets++; + OPERATOR(PERLY_QUESTION_MARK); case '.': - if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack + if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack #ifdef PERL_STRICT_CR - && s[1] == '\n' + && s[1] == '\n' #else - && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) + && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) #endif - && (s == PL_linestart || s[-1] == '\n') ) - { - PL_expect = XSTATE; + && (s == PL_linestart || s[-1] == '\n') ) + { + PL_expect = XSTATE; /* formbrack==2 means dot seen where arguments expected */ return yyl_rightcurly(aTHX_ s, 2); - } - if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') { - s += 3; - OPERATOR(YADAYADA); - } - if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { - char tmp = *s++; - if (*s == tmp) { - if (!PL_lex_allbrackets + } + if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') { + s += 3; + OPERATOR(YADAYADA); + } + if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { + char tmp = *s++; + if (*s == tmp) { + if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) { - s--; - TOKEN(0); - } - s++; - if (*s == tmp) { - s++; - pl_yylval.ival = OPf_SPECIAL; - } - else - pl_yylval.ival = 0; - OPERATOR(DOTDOT); - } - if (*s == '=' && !PL_lex_allbrackets + s--; + TOKEN(0); + } + s++; + if (*s == tmp) { + s++; + pl_yylval.ival = OPf_SPECIAL; + } + else + pl_yylval.ival = 0; + OPERATOR(DOTDOT); + } + if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { - s--; - TOKEN(0); - } - Aop(OP_CONCAT); - } - /* FALLTHROUGH */ + s--; + TOKEN(0); + } + Aop(OP_CONCAT); + } + /* FALLTHROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - s = scan_num(s, &pl_yylval); - DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); - if (PL_expect == XOPERATOR) - no_op("Number",s); - TERM(THING); + s = scan_num(s, &pl_yylval); + DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); + if (PL_expect == XOPERATOR) + no_op("Number",s); + TERM(THING); case '\'': return yyl_sglquote(aTHX_ s); @@ -9116,50 +9116,50 @@ yyl_try(pTHX_ char *s) return yyl_backslash(aTHX_ s + 1); case 'v': - if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { - char *start = s + 2; - while (isDIGIT(*start) || *start == '_') - start++; - if (*start == '.' && isDIGIT(start[1])) { - s = scan_num(s, &pl_yylval); - TERM(THING); - } - else if ((*start == ':' && start[1] == ':') + if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { + char *start = s + 2; + while (isDIGIT(*start) || *start == '_') + start++; + if (*start == '.' && isDIGIT(start[1])) { + s = scan_num(s, &pl_yylval); + TERM(THING); + } + else if ((*start == ':' && start[1] == ':') || (PL_expect == XSTATE && *start == ':')) { if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) return tok; goto retry_bufptr; } - else if (PL_expect == XSTATE) { - d = start; - while (d < PL_bufend && isSPACE(*d)) d++; - if (*d == ':') { + else if (PL_expect == XSTATE) { + d = start; + while (d < PL_bufend && isSPACE(*d)) d++; + if (*d == ':') { if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) return tok; goto retry_bufptr; } - } - /* avoid v123abc() or $h{v1}, allow C */ - if (!isALPHA(*start) && (PL_expect == XTERM - || PL_expect == XREF || PL_expect == XSTATE - || PL_expect == XTERMORDORDOR)) { - GV *const gv = gv_fetchpvn_flags(s, start - s, + } + /* avoid v123abc() or $h{v1}, allow C */ + if (!isALPHA(*start) && (PL_expect == XTERM + || PL_expect == XREF || PL_expect == XSTATE + || PL_expect == XTERMORDORDOR)) { + GV *const gv = gv_fetchpvn_flags(s, start - s, UTF ? SVf_UTF8 : 0, SVt_PVCV); - if (!gv) { - s = scan_num(s, &pl_yylval); - TERM(THING); - } - } - } + if (!gv) { + s = scan_num(s, &pl_yylval); + TERM(THING); + } + } + } if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) return tok; goto retry_bufptr; case 'x': - if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { - s++; - Mop(OP_REPEAT); - } + if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { + s++; + Mop(OP_REPEAT); + } if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) return tok; goto retry_bufptr; @@ -9186,9 +9186,9 @@ yyl_try(pTHX_ char *s) case 's': case 'S': case 't': case 'T': case 'u': case 'U': - case 'V': + case 'V': case 'w': case 'W': - case 'X': + case 'X': case 'y': case 'Y': case 'z': case 'Z': if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY) @@ -9211,35 +9211,35 @@ yyl_try(pTHX_ char *s) Structure: Check if we have already built the token; if so, use it. Switch based on the current state: - - if we have a case modifier in a string, deal with that - - handle other cases of interpolation inside a string - - scan the next line if we are inside a format + - if we have a case modifier in a string, deal with that + - handle other cases of interpolation inside a string + - scan the next line if we are inside a format In the normal state, switch on the next character: - - default: - if alphabetic, go to key lookup - unrecognized character - croak - - 0/4/26: handle end-of-line or EOF - - cases for whitespace - - \n and #: handle comments and line numbers - - various operators, brackets and sigils - - numbers - - quotes - - 'v': vstrings (or go to key lookup) - - 'x' repetition operator (or go to key lookup) - - other ASCII alphanumerics (key lookup begins here): - word before => ? - keyword plugin - scan built-in keyword (but do nothing with it yet) - check for statement label - check for lexical subs - return yyl_just_a_word if there is one - see whether built-in keyword is overridden - switch on keyword number: - - default: return yyl_just_a_word: - not a built-in keyword; handle bareword lookup - disambiguate between method and sub call - fall back to bareword - - cases for built-in keywords + - default: + if alphabetic, go to key lookup + unrecognized character - croak + - 0/4/26: handle end-of-line or EOF + - cases for whitespace + - \n and #: handle comments and line numbers + - various operators, brackets and sigils + - numbers + - quotes + - 'v': vstrings (or go to key lookup) + - 'x' repetition operator (or go to key lookup) + - other ASCII alphanumerics (key lookup begins here): + word before => ? + keyword plugin + scan built-in keyword (but do nothing with it yet) + check for statement label + check for lexical subs + return yyl_just_a_word if there is one + see whether built-in keyword is overridden + switch on keyword number: + - default: return yyl_just_a_word: + not a built-in keyword; handle bareword lookup + disambiguate between method and sub call + fall back to bareword + - cases for built-in keywords */ int @@ -9262,171 +9262,171 @@ Perl_yylex(pTHX) PL_parser->recheck_utf8_validity = FALSE; } DEBUG_T( { - SV* tmp = newSVpvs(""); - PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n", - (IV)CopLINE(PL_curcop), - lex_state_names[PL_lex_state], - exp_name[PL_expect], - pv_display(tmp, s, strlen(s), 0, 60)); - SvREFCNT_dec(tmp); + SV* tmp = newSVpvs(""); + PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n", + (IV)CopLINE(PL_curcop), + lex_state_names[PL_lex_state], + exp_name[PL_expect], + pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); } ); /* when we've already built the next token, just pull it out of the queue */ if (PL_nexttoke) { - PL_nexttoke--; - pl_yylval = PL_nextval[PL_nexttoke]; - { - I32 next_type; - next_type = PL_nexttype[PL_nexttoke]; - if (next_type & (7<<24)) { - if (next_type & (1<<24)) { - if (PL_lex_brackets > 100) - Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); - PL_lex_brackstack[PL_lex_brackets++] = - (char) ((next_type >> 16) & 0xff); - } - if (next_type & (2<<24)) - PL_lex_allbrackets++; - if (next_type & (4<<24)) - PL_lex_allbrackets--; - next_type &= 0xffff; - } - return REPORT(next_type == 'p' ? pending_ident() : next_type); - } + PL_nexttoke--; + pl_yylval = PL_nextval[PL_nexttoke]; + { + I32 next_type; + next_type = PL_nexttype[PL_nexttoke]; + if (next_type & (7<<24)) { + if (next_type & (1<<24)) { + if (PL_lex_brackets > 100) + Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); + PL_lex_brackstack[PL_lex_brackets++] = + (char) ((next_type >> 16) & 0xff); + } + if (next_type & (2<<24)) + PL_lex_allbrackets++; + if (next_type & (4<<24)) + PL_lex_allbrackets--; + next_type &= 0xffff; + } + return REPORT(next_type == 'p' ? pending_ident() : next_type); + } } switch (PL_lex_state) { case LEX_NORMAL: case LEX_INTERPNORMAL: - break; + break; /* interpolated case modifiers like \L \U, including \Q and \E. when we get here, PL_bufptr is at the \ */ case LEX_INTERPCASEMOD: - /* handle \E or end of string */ + /* handle \E or end of string */ return yyl_interpcasemod(aTHX_ s); case LEX_INTERPPUSH: return REPORT(sublex_push()); case LEX_INTERPSTART: - if (PL_bufptr == PL_bufend) - return REPORT(sublex_done()); - DEBUG_T({ + if (PL_bufptr == PL_bufend) + return REPORT(sublex_done()); + DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log, "### Interpolated variable\n"); }); - PL_expect = XTERM; + PL_expect = XTERM; /* for /@a/, we leave the joining for the regex engine to do * (unless we're within \Q etc) */ - PL_lex_dojoin = (*PL_bufptr == '@' + PL_lex_dojoin = (*PL_bufptr == '@' && (!PL_lex_inpat || PL_lex_casemods)); - PL_lex_state = LEX_INTERPNORMAL; - if (PL_lex_dojoin) { - NEXTVAL_NEXTTOKE.ival = 0; - force_next(PERLY_COMMA); - force_ident("\"", PERLY_DOLLAR); - NEXTVAL_NEXTTOKE.ival = 0; - force_next(PERLY_DOLLAR); - NEXTVAL_NEXTTOKE.ival = 0; - force_next((2<<24)|PERLY_PAREN_OPEN); - NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ - force_next(FUNC); - } - /* Convert (?{...}) and friends to 'do {...}' */ - if (PL_lex_inpat && *PL_bufptr == '(') { - PL_parser->lex_shared->re_eval_start = PL_bufptr; - PL_bufptr += 2; - if (*PL_bufptr != '{') - PL_bufptr++; - PL_expect = XTERMBLOCK; - force_next(DO); - } - - if (PL_lex_starts++) { - s = PL_bufptr; - /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ - if (!PL_lex_casemods && PL_lex_inpat) - TOKEN(PERLY_COMMA); - else - AopNOASSIGN(OP_CONCAT); - } - return yylex(); + PL_lex_state = LEX_INTERPNORMAL; + if (PL_lex_dojoin) { + NEXTVAL_NEXTTOKE.ival = 0; + force_next(PERLY_COMMA); + force_ident("\"", PERLY_DOLLAR); + NEXTVAL_NEXTTOKE.ival = 0; + force_next(PERLY_DOLLAR); + NEXTVAL_NEXTTOKE.ival = 0; + force_next((2<<24)|PERLY_PAREN_OPEN); + NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ + force_next(FUNC); + } + /* Convert (?{...}) and friends to 'do {...}' */ + if (PL_lex_inpat && *PL_bufptr == '(') { + PL_parser->lex_shared->re_eval_start = PL_bufptr; + PL_bufptr += 2; + if (*PL_bufptr != '{') + PL_bufptr++; + PL_expect = XTERMBLOCK; + force_next(DO); + } + + if (PL_lex_starts++) { + s = PL_bufptr; + /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ + if (!PL_lex_casemods && PL_lex_inpat) + TOKEN(PERLY_COMMA); + else + AopNOASSIGN(OP_CONCAT); + } + return yylex(); case LEX_INTERPENDMAYBE: - if (intuit_more(PL_bufptr, PL_bufend)) { - PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ - break; - } - /* FALLTHROUGH */ + if (intuit_more(PL_bufptr, PL_bufend)) { + PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ + break; + } + /* FALLTHROUGH */ case LEX_INTERPEND: - if (PL_lex_dojoin) { - const U8 dojoin_was = PL_lex_dojoin; - PL_lex_dojoin = FALSE; - PL_lex_state = LEX_INTERPCONCAT; - PL_lex_allbrackets--; - return REPORT(dojoin_was == 1 ? (int)PERLY_PAREN_CLOSE : (int)POSTJOIN); - } - if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl - && SvEVALED(PL_lex_repl)) - { - if (PL_bufptr != PL_bufend) - Perl_croak(aTHX_ "Bad evalled substitution pattern"); - PL_lex_repl = NULL; - } - /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets - re_eval_str. If the here-doc body’s length equals the previous - value of re_eval_start, re_eval_start will now be null. So - check re_eval_str as well. */ - if (PL_parser->lex_shared->re_eval_start - || PL_parser->lex_shared->re_eval_str) { - SV *sv; - if (*PL_bufptr != ')') - Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'"); - PL_bufptr++; - /* having compiled a (?{..}) expression, return the original - * text too, as a const */ - if (PL_parser->lex_shared->re_eval_str) { - sv = PL_parser->lex_shared->re_eval_str; - PL_parser->lex_shared->re_eval_str = NULL; - SvCUR_set(sv, - PL_bufptr - PL_parser->lex_shared->re_eval_start); - SvPV_shrink_to_cur(sv); - } - else sv = newSVpvn(PL_parser->lex_shared->re_eval_start, - PL_bufptr - PL_parser->lex_shared->re_eval_start); - NEXTVAL_NEXTTOKE.opval = + if (PL_lex_dojoin) { + const U8 dojoin_was = PL_lex_dojoin; + PL_lex_dojoin = FALSE; + PL_lex_state = LEX_INTERPCONCAT; + PL_lex_allbrackets--; + return REPORT(dojoin_was == 1 ? (int)PERLY_PAREN_CLOSE : (int)POSTJOIN); + } + if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl + && SvEVALED(PL_lex_repl)) + { + if (PL_bufptr != PL_bufend) + Perl_croak(aTHX_ "Bad evalled substitution pattern"); + PL_lex_repl = NULL; + } + /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets + re_eval_str. If the here-doc body’s length equals the previous + value of re_eval_start, re_eval_start will now be null. So + check re_eval_str as well. */ + if (PL_parser->lex_shared->re_eval_start + || PL_parser->lex_shared->re_eval_str) { + SV *sv; + if (*PL_bufptr != ')') + Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'"); + PL_bufptr++; + /* having compiled a (?{..}) expression, return the original + * text too, as a const */ + if (PL_parser->lex_shared->re_eval_str) { + sv = PL_parser->lex_shared->re_eval_str; + PL_parser->lex_shared->re_eval_str = NULL; + SvCUR_set(sv, + PL_bufptr - PL_parser->lex_shared->re_eval_start); + SvPV_shrink_to_cur(sv); + } + else sv = newSVpvn(PL_parser->lex_shared->re_eval_start, + PL_bufptr - PL_parser->lex_shared->re_eval_start); + NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, - sv); - force_next(THING); - PL_parser->lex_shared->re_eval_start = NULL; - PL_expect = XTERM; - return REPORT(PERLY_COMMA); - } - - /* FALLTHROUGH */ + sv); + force_next(THING); + PL_parser->lex_shared->re_eval_start = NULL; + PL_expect = XTERM; + return REPORT(PERLY_COMMA); + } + + /* FALLTHROUGH */ case LEX_INTERPCONCAT: #ifdef DEBUGGING - if (PL_lex_brackets) - Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld", - (long) PL_lex_brackets); + if (PL_lex_brackets) + Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld", + (long) PL_lex_brackets); #endif - if (PL_bufptr == PL_bufend) - return REPORT(sublex_done()); + if (PL_bufptr == PL_bufend) + return REPORT(sublex_done()); - /* m'foo' still needs to be parsed for possible (?{...}) */ - if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) { - SV *sv = newSVsv(PL_linestr); - sv = tokeq(sv); + /* m'foo' still needs to be parsed for possible (?{...}) */ + if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) { + SV *sv = newSVsv(PL_linestr); + sv = tokeq(sv); pl_yylval.opval = newSVOP(OP_CONST, 0, sv); - s = PL_bufend; - } - else { + s = PL_bufend; + } + else { int save_error_count = PL_error_count; - s = scan_const(PL_bufptr); + s = scan_const(PL_bufptr); /* Set flag if this was a pattern and there were errors. op.c will * refuse to compile a pattern with this flag set. Otherwise, we @@ -9434,30 +9434,30 @@ Perl_yylex(pTHX) if (PL_lex_inpat && PL_error_count > save_error_count) { ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR; } - if (*s == '\\') - PL_lex_state = LEX_INTERPCASEMOD; - else - PL_lex_state = LEX_INTERPSTART; - } - - if (s != PL_bufptr) { - NEXTVAL_NEXTTOKE = pl_yylval; - PL_expect = XTERM; - force_next(THING); - if (PL_lex_starts++) { - /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ - if (!PL_lex_casemods && PL_lex_inpat) - TOKEN(PERLY_COMMA); - else - AopNOASSIGN(OP_CONCAT); - } - else { - PL_bufptr = s; - return yylex(); - } - } - - return yylex(); + if (*s == '\\') + PL_lex_state = LEX_INTERPCASEMOD; + else + PL_lex_state = LEX_INTERPSTART; + } + + if (s != PL_bufptr) { + NEXTVAL_NEXTTOKE = pl_yylval; + PL_expect = XTERM; + force_next(THING); + if (PL_lex_starts++) { + /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ + if (!PL_lex_casemods && PL_lex_inpat) + TOKEN(PERLY_COMMA); + else + AopNOASSIGN(OP_CONCAT); + } + else { + PL_bufptr = s; + return yylex(); + } + } + + return yylex(); case LEX_FORMLINE: if (PL_parser->sub_error_count != PL_error_count) { /* There was an error parsing a formline, which tends to @@ -9467,12 +9467,12 @@ Perl_yylex(pTHX) */ yyquit(); } - assert(PL_lex_formbrack); - s = scan_formline(PL_bufptr); - if (!PL_lex_formbrack) + assert(PL_lex_formbrack); + s = scan_formline(PL_bufptr); + if (!PL_lex_formbrack) return yyl_rightcurly(aTHX_ s, 1); - PL_bufptr = s; - return yylex(); + PL_bufptr = s; + return yylex(); } /* We really do *not* want PL_linestr ever becoming a COW. */ @@ -9526,12 +9526,12 @@ Perl_yylex(pTHX) Structure: if we're in a my declaration - croak if they tried to say my($foo::bar) - build the ops for a my() declaration + croak if they tried to say my($foo::bar) + build the ops for a my() declaration if it's an access to a my() variable - build ops for access to a my() variable + build ops for access to a my() variable if in a dq string, and they've said @foo and we can't find @foo - warn + warn build ops for a bareword */ @@ -9602,7 +9602,7 @@ S_pending_ident(pTHX) PL_in_my = 0; pl_yylval.opval = o; - return PRIVATEREF; + return PRIVATEREF; } } @@ -9611,16 +9611,16 @@ S_pending_ident(pTHX) */ if (!has_colon) { - if (!PL_in_my) - tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len, + if (!PL_in_my) + tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len, 0); if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { /* build ops for a bareword */ - HV * const stash = PAD_COMPNAME_OURSTASH(tmp); - HEK * const stashname = HvNAME_HEK(stash); - SV * const sym = newSVhek(stashname); + HV * const stash = PAD_COMPNAME_OURSTASH(tmp); + HEK * const stashname = HvNAME_HEK(stash); + SV * const sym = newSVhek(stashname); sv_catpvs(sym, "::"); sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES )); pl_yylval.opval = newSVOP(OP_CONST, 0, sym); @@ -9654,29 +9654,29 @@ S_pending_ident(pTHX) ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG, SVt_PVAV); if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) - ) + ) { /* Downgraded from fatal to warning 20000522 mjd */ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Possible unintended interpolation of %" UTF8f - " in string", - UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf)); + "Possible unintended interpolation of %" UTF8f + " in string", + UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf)); } } /* build ops for a bareword */ pl_yylval.opval = newSVOP(OP_CONST, 0, - newSVpvn_flags(PL_tokenbuf + 1, + newSVpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, UTF ? SVf_UTF8 : 0 )); pl_yylval.opval->op_private = OPpCONST_ENTERED; if (pit != '&') gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, - (PL_in_eval ? GV_ADDMULTI : GV_ADD) + (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); return BAREWORD; } @@ -9686,57 +9686,57 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) PERL_ARGS_ASSERT_CHECKCOMMA; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - if (ckWARN(WARN_SYNTAX)) { - int level = 1; - const char *w; - for (w = s+2; *w && level; w++) { - if (*w == '(') - ++level; - else if (*w == ')') - --level; - } - while (isSPACE(*w)) - ++w; - /* the list of chars below is for end of statements or - * block / parens, boolean operators (&&, ||, //) and branch - * constructs (or, and, if, until, unless, while, err, for). - * Not a very solid hack... */ - if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "%s (...) interpreted as function",name); - } + if (ckWARN(WARN_SYNTAX)) { + int level = 1; + const char *w; + for (w = s+2; *w && level; w++) { + if (*w == '(') + ++level; + else if (*w == ')') + --level; + } + while (isSPACE(*w)) + ++w; + /* the list of chars below is for end of statements or + * block / parens, boolean operators (&&, ||, //) and branch + * constructs (or, and, if, until, unless, while, err, for). + * Not a very solid hack... */ + if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "%s (...) interpreted as function",name); + } } while (s < PL_bufend && isSPACE(*s)) - s++; + s++; if (*s == '(') - s++; + s++; while (s < PL_bufend && isSPACE(*s)) - s++; + s++; if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) { - const char * const w = s; + const char * const w = s; s += UTF ? UTF8SKIP(s) : 1; - while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) - s += UTF ? UTF8SKIP(s) : 1; - while (s < PL_bufend && isSPACE(*s)) - s++; - if (*s == ',') { - GV* gv; - if (keyword(w, s - w, 0)) - return; - - gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); - if (gv && GvCVu(gv)) - return; - if (s - w <= 254) { + while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) + s += UTF ? UTF8SKIP(s) : 1; + while (s < PL_bufend && isSPACE(*s)) + s++; + if (*s == ',') { + GV* gv; + if (keyword(w, s - w, 0)) + return; + + gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); + if (gv && GvCVu(gv)) + return; + if (s - w <= 254) { PADOFFSET off; - char tmpbuf[256]; - Copy(w, tmpbuf+1, s - w, char); - *tmpbuf = '&'; - off = pad_findmy_pvn(tmpbuf, s-w+1, 0); - if (off != NOT_IN_PAD) return; - } - Perl_croak(aTHX_ "No comma allowed after %s", what); - } + char tmpbuf[256]; + Copy(w, tmpbuf+1, s - w, char); + *tmpbuf = '&'; + off = pad_findmy_pvn(tmpbuf, s-w+1, 0); + if (off != NOT_IN_PAD) return; + } + Perl_croak(aTHX_ "No comma allowed after %s", what); + } } } @@ -9753,7 +9753,7 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) STATIC SV * S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, - SV *sv, SV *pv, const char *type, STRLEN typelen, + SV *sv, SV *pv, const char *type, STRLEN typelen, const char ** error_msg) { dSP; @@ -9773,7 +9773,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, sv_2mortal(sv); /* Parent created it permanently */ if ( ! table - || ! (PL_hints & HINT_LOCALIZE_HH)) + || ! (PL_hints & HINT_LOCALIZE_HH)) { why1 = "unknown"; optional_colon = ""; @@ -9790,11 +9790,11 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, cv = *cvp; if (!pv && s) - pv = newSVpvn_flags(s, len, SVs_TEMP); + pv = newSVpvn_flags(s, len, SVs_TEMP); if (type && pv) - typesv = newSVpvn_flags(type, typelen, SVs_TEMP); + typesv = newSVpvn_flags(type, typelen, SVs_TEMP); else - typesv = &PL_sv_undef; + typesv = &PL_sv_undef; PUSHSTACKi(PERLSI_OVERLOAD); ENTER ; @@ -9803,10 +9803,10 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, PUSHMARK(SP) ; EXTEND(sp, 3); if (pv) - PUSHs(pv); + PUSHs(pv); PUSHs(sv); if (pv) - PUSHs(typesv); + PUSHs(typesv); PUTBACK; call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); @@ -9814,17 +9814,17 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, /* Check the eval first */ if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) { - STRLEN errlen; - const char * errstr; - sv_catpvs(errsv, "Propagated"); - errstr = SvPV_const(errsv, errlen); - yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */ - (void)POPs; - res = SvREFCNT_inc_simple_NN(sv); + STRLEN errlen; + const char * errstr; + sv_catpvs(errsv, "Propagated"); + errstr = SvPV_const(errsv, errlen); + yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */ + (void)POPs; + res = SvREFCNT_inc_simple_NN(sv); } else { - res = POPs; - SvREFCNT_inc_simple_void_NN(res); + res = POPs; + SvREFCNT_inc_simple_void_NN(res); } PUTBACK ; @@ -9915,7 +9915,7 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) { char *this_d; - char *d2; + char *d2; Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */ d2 = this_d; SAVEFREEPV(this_d); @@ -9929,7 +9929,7 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, *d2++ = '\\'; *d2++ = *olds++; } - else + else *d2++ = *olds++; } Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -9990,7 +9990,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) PERL_ARGS_ASSERT_SCAN_IDENT; if (isSPACE(*s) || !*s) - s = skipspace(s); + s = skipspace(s); if (isDIGIT(*s)) { /* handle $0 and $1 $2 and $10 and etc */ bool is_zero= *s == '0' ? TRUE : FALSE; char *digit_start= d; @@ -10011,9 +10011,9 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) if (*d) { /* Either a digit variable, or parse_ident() found an identifier (anything valid as a bareword), so job done and return. */ - if (PL_lex_state != LEX_NORMAL) - PL_lex_state = LEX_INTERPENDMAYBE; - return s; + if (PL_lex_state != LEX_NORMAL) + PL_lex_state = LEX_INTERPENDMAYBE; + return s; } /* Here, it is not a run-of-the-mill identifier name */ @@ -10028,13 +10028,13 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) /* Dereferencing a value in a scalar variable. The alternatives are different syntaxes for a scalar variable. Using ' as a leading package separator isn't allowed. :: is. */ - return s; + return s; } /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */ if (*s == '{') { - bracket = s - SvPVX(PL_linestr); - s++; - orig_copline = CopLINE(PL_curcop); + bracket = s - SvPVX(PL_linestr); + s++; + orig_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { s = skipspace(s); } @@ -10071,14 +10071,14 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) } /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */ if (*d == '^' && *s && isCONTROLVAR(*s)) { - *d = toCTRL(*s); - s++; + *d = toCTRL(*s); + s++; } /* Warn about ambiguous code after unary operators if {...} notation isn't used. There's no difference in ambiguity; it's merely a heuristic about when not to warn. */ else if (ck_uni && bracket == -1) - check_uni(); + check_uni(); if (bracket != -1) { bool skip; char *s2; @@ -10111,26 +10111,26 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) if (s < PL_bufend && isSPACE(*s)) { s = skipspace(s); } - if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { + if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */ - if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { - const char * const brack = - (const char *) - ((*s == '[') ? "[...]" : "{...}"); + if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { + const char * const brack = + (const char *) + ((*s == '[') ? "[...]" : "{...}"); orig_copline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, tmp_copline); /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */ - Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous use of %c{%s%s} resolved to %c%s%s", - funny, dest, brack, funny, dest, brack); + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous use of %c{%s%s} resolved to %c%s%s", + funny, dest, brack, funny, dest, brack); CopLINE_set(PL_curcop, orig_copline); - } - bracket++; - PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); - PL_lex_allbrackets++; - return s; - } - } + } + bracket++; + PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); + PL_lex_allbrackets++; + return s; + } + } if ( !tmp_copline ) tmp_copline = CopLINE(PL_curcop); @@ -10150,45 +10150,45 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) /* Now increment line numbers if applicable. */ if (skip) s = skipspace(s); - s++; - if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { - PL_lex_state = LEX_INTERPEND; - PL_expect = XREF; - } - if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) { - if (ckWARN(WARN_AMBIGUOUS) + s++; + if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { + PL_lex_state = LEX_INTERPEND; + PL_expect = XREF; + } + if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) { + if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest, 0) - || get_cvn_flags(dest, d - dest, is_utf8 + || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0))) - { + { SV *tmp = newSVpvn_flags( dest, d - dest, SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) ); - if (funny == '#') - funny = '@'; + if (funny == '#') + funny = '@'; orig_copline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, tmp_copline); - Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf, - funny, SVfARG(tmp), funny, SVfARG(tmp)); + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf, + funny, SVfARG(tmp), funny, SVfARG(tmp)); CopLINE_set(PL_curcop, orig_copline); - } - } - } - else { + } + } + } + else { /* Didn't find the closing } at the point we expected, so restore state such that the next thing to process is the opening { and */ - s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */ + s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */ CopLINE_set(PL_curcop, orig_copline); PL_parser->herelines = herelines; - *dest = '\0'; + *dest = '\0'; PL_parser->sub_no_recover = TRUE; - } + } } else if ( PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s, PL_bufend)) - PL_lex_state = LEX_INTERPEND; + PL_lex_state = LEX_INTERPEND; return s; } @@ -10228,65 +10228,65 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break; case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break; - case LOCALE_PAT_MOD: - if (*charset) { - goto multiple_charsets; - } - set_regex_charset(pmfl, REGEX_LOCALE_CHARSET); - *charset = c; - break; - case UNICODE_PAT_MOD: - if (*charset) { - goto multiple_charsets; - } - set_regex_charset(pmfl, REGEX_UNICODE_CHARSET); - *charset = c; - break; - case ASCII_RESTRICT_PAT_MOD: - if (! *charset) { - set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET); - } - else { - - /* Error if previous modifier wasn't an 'a', but if it was, see - * if, and accept, a second occurrence (only) */ - if (*charset != 'a' - || get_regex_charset(*pmfl) - != REGEX_ASCII_RESTRICTED_CHARSET) - { - goto multiple_charsets; - } - set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET); - } - *charset = c; - break; - case DEPENDS_PAT_MOD: - if (*charset) { - goto multiple_charsets; - } - set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET); - *charset = c; - break; + case LOCALE_PAT_MOD: + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_LOCALE_CHARSET); + *charset = c; + break; + case UNICODE_PAT_MOD: + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_UNICODE_CHARSET); + *charset = c; + break; + case ASCII_RESTRICT_PAT_MOD: + if (! *charset) { + set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET); + } + else { + + /* Error if previous modifier wasn't an 'a', but if it was, see + * if, and accept, a second occurrence (only) */ + if (*charset != 'a' + || get_regex_charset(*pmfl) + != REGEX_ASCII_RESTRICTED_CHARSET) + { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET); + } + *charset = c; + break; + case DEPENDS_PAT_MOD: + if (*charset) { + goto multiple_charsets; + } + set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET); + *charset = c; + break; } (*s)++; return TRUE; multiple_charsets: - if (*charset != c) { - yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); - } - else if (c == 'a') { + if (*charset != c) { + yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); + } + else if (c == 'a') { /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */ - yyerror("Regexp modifier \"/a\" may appear a maximum of twice"); - } - else { - yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c)); - } + yyerror("Regexp modifier \"/a\" may appear a maximum of twice"); + } + else { + yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c)); + } - /* Pretend that it worked, so will continue processing before dieing */ - (*s)++; - return TRUE; + /* Pretend that it worked, so will continue processing before dieing */ + (*s)++; + return TRUE; } STATIC char * @@ -10295,7 +10295,7 @@ S_scan_pat(pTHX_ char *start, I32 type) PMOP *pm; char *s; const char * const valid_flags = - (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); + (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); char charset = '\0'; /* character set modifier */ unsigned int x_mod_count = 0; @@ -10303,48 +10303,48 @@ S_scan_pat(pTHX_ char *start, I32 type) s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL); if (!s) - Perl_croak(aTHX_ "Search pattern not terminated"); + Perl_croak(aTHX_ "Search pattern not terminated"); pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') { - /* This is the only point in the code that sets PMf_ONCE: */ - pm->op_pmflags |= PMf_ONCE; - - /* Hence it's safe to do this bit of PMOP book-keeping here, which - allows us to restrict the list needed by reset to just the ?? - matches. */ - assert(type != OP_TRANS); - if (PL_curstash) { - MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab); - U32 elements; - if (!mg) { - mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0, - 0); - } - elements = mg->mg_len / sizeof(PMOP**); - Renewc(mg->mg_ptr, elements + 1, PMOP*, char); - ((PMOP**)mg->mg_ptr) [elements++] = pm; - mg->mg_len = elements * sizeof(PMOP**); - PmopSTASH_set(pm,PL_curstash); - } + /* This is the only point in the code that sets PMf_ONCE: */ + pm->op_pmflags |= PMf_ONCE; + + /* Hence it's safe to do this bit of PMOP book-keeping here, which + allows us to restrict the list needed by reset to just the ?? + matches. */ + assert(type != OP_TRANS); + if (PL_curstash) { + MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab); + U32 elements; + if (!mg) { + mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0, + 0); + } + elements = mg->mg_len / sizeof(PMOP**); + Renewc(mg->mg_ptr, elements + 1, PMOP*, char); + ((PMOP**)mg->mg_ptr) [elements++] = pm; + mg->mg_len = elements * sizeof(PMOP**); + PmopSTASH_set(pm,PL_curstash); + } } /* if qr/...(?{..}).../, then need to parse the pattern within a new * anon CV. False positives like qr/[(?{]/ are harmless */ if (type == OP_QR) { - STRLEN len; - char *e, *p = SvPV(PL_lex_stuff, len); - e = p + len; - for (; p < e; p++) { - if (p[0] == '(' && p[1] == '?' - && (p[2] == '{' || (p[2] == '?' && p[3] == '{'))) - { - pm->op_pmflags |= PMf_HAS_CV; - break; - } - } - pm->op_pmflags |= PMf_IS_QR; + STRLEN len; + char *e, *p = SvPV(PL_lex_stuff, len); + e = p + len; + for (; p < e; p++) { + if (p[0] == '(' && p[1] == '?' + && (p[2] == '{' || (p[2] == '?' && p[3] == '{'))) + { + pm->op_pmflags |= PMf_HAS_CV; + break; + } + } + pm->op_pmflags |= PMf_IS_QR; } while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), @@ -10354,7 +10354,7 @@ S_scan_pat(pTHX_ char *start, I32 type) if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /c modifier is meaningless without /g" ); + "Use of /c modifier is meaningless without /g" ); } PL_lex_op = (OP*)pm; @@ -10382,7 +10382,7 @@ S_scan_subst(pTHX_ char *start) s = scan_str(start, TRUE, FALSE, FALSE, &t); if (!s) - Perl_croak(aTHX_ "Substitution pattern not terminated"); + Perl_croak(aTHX_ "Substitution pattern not terminated"); s = t; @@ -10390,9 +10390,9 @@ S_scan_subst(pTHX_ char *start) first_line = CopLINE(PL_curcop); s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { - SvREFCNT_dec_NN(PL_lex_stuff); - PL_lex_stuff = NULL; - Perl_croak(aTHX_ "Substitution replacement not terminated"); + SvREFCNT_dec_NN(PL_lex_stuff); + PL_lex_stuff = NULL; + Perl_croak(aTHX_ "Substitution replacement not terminated"); } PL_multi_start = first_start; /* so whole substitution is taken together */ @@ -10400,15 +10400,15 @@ S_scan_subst(pTHX_ char *start) while (*s) { - if (*s == EXEC_PAT_MOD) { - s++; - es++; - } - else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), + if (*s == EXEC_PAT_MOD) { + s++; + es++; + } + else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset, &x_mod_count)) - { - break; - } + { + break; + } } if ((pm->op_pmflags & PMf_CONTINUE)) { @@ -10416,24 +10416,24 @@ S_scan_subst(pTHX_ char *start) } if (es) { - SV * const repl = newSVpvs(""); + SV * const repl = newSVpvs(""); - PL_multi_end = 0; - pm->op_pmflags |= PMf_EVAL; + PL_multi_end = 0; + pm->op_pmflags |= PMf_EVAL; for (; es > 1; es--) { sv_catpvs(repl, "eval "); } sv_catpvs(repl, "do {"); - sv_catsv(repl, PL_parser->lex_sub_repl); - sv_catpvs(repl, "}"); - SvREFCNT_dec(PL_parser->lex_sub_repl); - PL_parser->lex_sub_repl = repl; + sv_catsv(repl, PL_parser->lex_sub_repl); + sv_catpvs(repl, "}"); + SvREFCNT_dec(PL_parser->lex_sub_repl); + PL_parser->lex_sub_repl = repl; } linediff = CopLINE(PL_curcop) - first_line; if (linediff) - CopLINE_set(PL_curcop, first_line); + CopLINE_set(PL_curcop, first_line); if (linediff || es) { /* the IVX field indicates that the replacement string is a s///e; @@ -10467,36 +10467,36 @@ S_scan_trans(pTHX_ char *start) s = scan_str(start,FALSE,FALSE,FALSE,&t); if (!s) - Perl_croak(aTHX_ "Transliteration pattern not terminated"); + Perl_croak(aTHX_ "Transliteration pattern not terminated"); s = t; s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { - SvREFCNT_dec_NN(PL_lex_stuff); - PL_lex_stuff = NULL; - Perl_croak(aTHX_ "Transliteration replacement not terminated"); + SvREFCNT_dec_NN(PL_lex_stuff); + PL_lex_stuff = NULL; + Perl_croak(aTHX_ "Transliteration replacement not terminated"); } complement = del = squash = 0; while (1) { - switch (*s) { - case 'c': - complement = OPpTRANS_COMPLEMENT; - break; - case 'd': - del = OPpTRANS_DELETE; - break; - case 's': - squash = OPpTRANS_SQUASH; - break; - case 'r': - nondestruct = 1; - break; - default: - goto no_more; - } - s++; + switch (*s) { + case 'c': + complement = OPpTRANS_COMPLEMENT; + break; + case 'd': + del = OPpTRANS_DELETE; + break; + case 's': + squash = OPpTRANS_SQUASH; + break; + case 'r': + nondestruct = 1; + break; + default: + goto no_more; + } + s++; } no_more: @@ -10561,46 +10561,46 @@ S_scan_heredoc(pTHX_ char *s) peek = s; if (*peek == '~') { - indented = TRUE; - peek++; s++; + indented = TRUE; + peek++; s++; } while (SPACE_OR_TAB(*peek)) - peek++; + peek++; if (*peek == '`' || *peek == '\'' || *peek =='"') { - s = peek; - term = *s++; - s = delimcpy(d, e, s, PL_bufend, term, &len); - if (s == PL_bufend) - Perl_croak(aTHX_ "Unterminated delimiter for here document"); - d += len; - s++; + s = peek; + term = *s++; + s = delimcpy(d, e, s, PL_bufend, term, &len); + if (s == PL_bufend) + Perl_croak(aTHX_ "Unterminated delimiter for here document"); + d += len; + s++; } else { - if (*s == '\\') + if (*s == '\\') /* <<\FOO is equivalent to <<'FOO' */ - s++, term = '\''; - else - term = '"'; + s++, term = '\''; + else + term = '"'; - if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) - Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden"); + if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) + Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden"); - peek = s; + peek = s; while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) { - peek += UTF ? UTF8SKIP(peek) : 1; - } + peek += UTF ? UTF8SKIP(peek) : 1; + } - len = (peek - s >= e - d) ? (e - d) : (peek - s); - Copy(s, d, len, char); - s += len; - d += len; + len = (peek - s >= e - d) ? (e - d) : (peek - s); + Copy(s, d, len, char); + s += len; + d += len; } if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1) - Perl_croak(aTHX_ "Delimiter for here document is too long"); + Perl_croak(aTHX_ "Delimiter for here document is too long"); *d++ = '\n'; *d = '\0'; @@ -10609,37 +10609,37 @@ S_scan_heredoc(pTHX_ char *s) #ifndef PERL_STRICT_CR d = (char *) memchr(s, '\r', PL_bufend - s); if (d) { - char * const olds = s; - s = d; - while (s < PL_bufend) { - if (*s == '\r') { - *d++ = '\n'; - if (*++s == '\n') - s++; - } - else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ - *d++ = *s++; - s++; - } - else - *d++ = *s++; - } - *d = '\0'; - PL_bufend = d; - SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); - s = olds; + char * const olds = s; + s = d; + while (s < PL_bufend) { + if (*s == '\r') { + *d++ = '\n'; + if (*++s == '\n') + s++; + } + else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ + *d++ = *s++; + s++; + } + else + *d++ = *s++; + } + *d = '\0'; + PL_bufend = d; + SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); + s = olds; } #endif tmpstr = newSV_type(SVt_PVIV); SvGROW(tmpstr, 80); if (term == '\'') { - op_type = OP_CONST; - SvIV_set(tmpstr, -1); + op_type = OP_CONST; + SvIV_set(tmpstr, -1); } else if (term == '`') { - op_type = OP_BACKTICK; - SvIV_set(tmpstr, '\\'); + op_type = OP_BACKTICK; + SvIV_set(tmpstr, '\\'); } PL_multi_start = origline + 1 + PL_parser->herelines; @@ -10647,14 +10647,14 @@ S_scan_heredoc(pTHX_ char *s) /* inside a string eval or quote-like operator */ if (!infile || PL_lex_inwhat) { - SV *linestr; - char *bufend; - char * const olds = s; - PERL_CONTEXT * const cx = CX_CUR(); - /* These two fields are not set until an inner lexing scope is - entered. But we need them set here. */ - shared->ls_bufptr = s; - shared->ls_linestr = PL_linestr; + SV *linestr; + char *bufend; + char * const olds = s; + PERL_CONTEXT * const cx = CX_CUR(); + /* These two fields are not set until an inner lexing scope is + entered. But we need them set here. */ + shared->ls_bufptr = s; + shared->ls_linestr = PL_linestr; if (PL_lex_inwhat) { /* Look for a newline. If the current buffer does not have one, @@ -10662,10 +10662,10 @@ S_scan_heredoc(pTHX_ char *s) up as many levels as necessary to find one with a newline after bufptr. */ - while (!(s = (char *)memchr( + while (!(s = (char *)memchr( (void *)shared->ls_bufptr, '\n', SvEND(shared->ls_linestr)-shared->ls_bufptr - ))) + ))) { shared = shared->ls_prev; /* shared is only null if we have gone beyond the outermost @@ -10690,100 +10690,100 @@ S_scan_heredoc(pTHX_ char *s) } } } - else { /* eval or we've already hit EOF */ - s = (char*)memchr((void*)s, '\n', PL_bufend - s); - if (!s) + else { /* eval or we've already hit EOF */ + s = (char*)memchr((void*)s, '\n', PL_bufend - s); + if (!s) goto interminable; - } - - linestr = shared->ls_linestr; - bufend = SvEND(linestr); - d = s; - if (indented) { - char *myolds = s; - - while (s < bufend - len + 1) { - if (*s++ == '\n') - ++PL_parser->herelines; - - if (memEQ(s, PL_tokenbuf + 1, len - 1)) { - char *backup = s; - indent_len = 0; - - /* Only valid if it's preceded by whitespace only */ - while (backup != myolds && --backup >= myolds) { - if (! SPACE_OR_TAB(*backup)) { - break; - } - indent_len++; - } - - /* No whitespace or all! */ - if (backup == s || *backup == '\n') { - Newx(indent, indent_len + 1, char); - memcpy(indent, backup + 1, indent_len); - indent[indent_len] = 0; - s--; /* before our delimiter */ - PL_parser->herelines--; /* this line doesn't count */ - break; - } - } - } - } + } + + linestr = shared->ls_linestr; + bufend = SvEND(linestr); + d = s; + if (indented) { + char *myolds = s; + + while (s < bufend - len + 1) { + if (*s++ == '\n') + ++PL_parser->herelines; + + if (memEQ(s, PL_tokenbuf + 1, len - 1)) { + char *backup = s; + indent_len = 0; + + /* Only valid if it's preceded by whitespace only */ + while (backup != myolds && --backup >= myolds) { + if (! SPACE_OR_TAB(*backup)) { + break; + } + indent_len++; + } + + /* No whitespace or all! */ + if (backup == s || *backup == '\n') { + Newx(indent, indent_len + 1, char); + memcpy(indent, backup + 1, indent_len); + indent[indent_len] = 0; + s--; /* before our delimiter */ + PL_parser->herelines--; /* this line doesn't count */ + break; + } + } + } + } else { - while (s < bufend - len + 1 - && memNE(s,PL_tokenbuf,len) ) - { - if (*s++ == '\n') - ++PL_parser->herelines; - } - } - - if (s >= bufend - len + 1) { - goto interminable; - } - - sv_setpvn(tmpstr,d+1,s-d); - s += len - 1; - /* the preceding stmt passes a newline */ - PL_parser->herelines++; - - /* s now points to the newline after the heredoc terminator. - d points to the newline before the body of the heredoc. - */ - - /* We are going to modify linestr in place here, so set - aside copies of the string if necessary for re-evals or - (caller $n)[6]. */ - /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we - check shared->re_eval_str. */ - if (shared->re_eval_start || shared->re_eval_str) { - /* Set aside the rest of the regexp */ - if (!shared->re_eval_str) - shared->re_eval_str = - newSVpvn(shared->re_eval_start, - bufend - shared->re_eval_start); - shared->re_eval_start -= s-d; - } - - if (cxstack_ix >= 0 + while (s < bufend - len + 1 + && memNE(s,PL_tokenbuf,len) ) + { + if (*s++ == '\n') + ++PL_parser->herelines; + } + } + + if (s >= bufend - len + 1) { + goto interminable; + } + + sv_setpvn(tmpstr,d+1,s-d); + s += len - 1; + /* the preceding stmt passes a newline */ + PL_parser->herelines++; + + /* s now points to the newline after the heredoc terminator. + d points to the newline before the body of the heredoc. + */ + + /* We are going to modify linestr in place here, so set + aside copies of the string if necessary for re-evals or + (caller $n)[6]. */ + /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we + check shared->re_eval_str. */ + if (shared->re_eval_start || shared->re_eval_str) { + /* Set aside the rest of the regexp */ + if (!shared->re_eval_str) + shared->re_eval_str = + newSVpvn(shared->re_eval_start, + bufend - shared->re_eval_start); + shared->re_eval_start -= s-d; + } + + if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL && cx->blk_eval.cur_text == linestr) { - cx->blk_eval.cur_text = newSVsv(linestr); - 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); - SvCUR_set(linestr, SvCUR(linestr) - (s-d)); - /* Setting PL_bufend only applies when we have not dug deeper - into other scopes, because sublex_done sets PL_bufend to - SvEND(PL_linestr). */ - if (shared == PL_parser->lex_shared) + cx->blk_eval.cur_text = newSVsv(linestr); + 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); + SvCUR_set(linestr, SvCUR(linestr) - (s-d)); + /* Setting PL_bufend only applies when we have not dug deeper + into other scopes, because sublex_done sets PL_bufend to + SvEND(PL_linestr). */ + if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr); - s = olds; + s = olds; } else { SV *linestr_save; @@ -10908,59 +10908,59 @@ S_scan_heredoc(pTHX_ char *s) PL_multi_end = origline + PL_parser->herelines; if (indented && indent) { - STRLEN linecount = 1; - STRLEN herelen = SvCUR(tmpstr); - char *ss = SvPVX(tmpstr); - char *se = ss + herelen; + STRLEN linecount = 1; + STRLEN herelen = SvCUR(tmpstr); + char *ss = SvPVX(tmpstr); + char *se = ss + herelen; SV *newstr = newSV(herelen+1); SvPOK_on(newstr); - /* Trim leading whitespace */ - while (ss < se) { - /* newline only? Copy and move on */ - if (*ss == '\n') { - sv_catpvs(newstr,"\n"); - ss++; - linecount++; + /* Trim leading whitespace */ + while (ss < se) { + /* newline only? Copy and move on */ + if (*ss == '\n') { + sv_catpvs(newstr,"\n"); + ss++; + linecount++; - /* Found our indentation? Strip it */ - } + /* Found our indentation? Strip it */ + } else if (se - ss >= indent_len - && memEQ(ss, indent, indent_len)) - { - STRLEN le = 0; - ss += indent_len; + && memEQ(ss, indent, indent_len)) + { + STRLEN le = 0; + ss += indent_len; - while ((ss + le) < se && *(ss + le) != '\n') - le++; + while ((ss + le) < se && *(ss + le) != '\n') + le++; - sv_catpvn(newstr, ss, le); - ss += le; + sv_catpvn(newstr, ss, le); + ss += le; - /* Line doesn't begin with our indentation? Croak */ - } + /* Line doesn't begin with our indentation? Croak */ + } else { Safefree(indent); - Perl_croak(aTHX_ - "Indentation on line %d of here-doc doesn't match delimiter", - (int)linecount - ); - } - } /* while */ + Perl_croak(aTHX_ + "Indentation on line %d of here-doc doesn't match delimiter", + (int)linecount + ); + } + } /* while */ /* avoid sv_setsv() as we dont wan't to COW here */ sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr)); - Safefree(indent); - SvREFCNT_dec_NN(newstr); + Safefree(indent); + SvREFCNT_dec_NN(newstr); } if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { - SvPV_shrink_to_cur(tmpstr); + SvPV_shrink_to_cur(tmpstr); } if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) - SvUTF8_on(tmpstr); + if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) + SvUTF8_on(tmpstr); } PL_lex_stuff = tmpstr; @@ -10969,7 +10969,7 @@ S_scan_heredoc(pTHX_ char *s) interminable: if (indent) - Safefree(indent); + Safefree(indent); SvREFCNT_dec(tmpstr); CopLINE_set(PL_curcop, origline); missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1); @@ -10979,7 +10979,7 @@ S_scan_heredoc(pTHX_ char *s) /* scan_inputsymbol takes: position of first '<' in input buffer returns: position of first char following the matching '>' in - input buffer + input buffer side-effects: pl_yylval and lex_op are set. This code handles: @@ -11008,7 +11008,7 @@ S_scan_inputsymbol(pTHX_ char *start) end = (char *) memchr(s, '\n', PL_bufend - s); if (!end) - end = PL_bufend; + end = PL_bufend; if (s[1] == '<' && s[2] == '>' && s[3] == '>') { nomagicopen = TRUE; *d = '\0'; @@ -11023,9 +11023,9 @@ S_scan_inputsymbol(pTHX_ char *start) */ if (len >= (I32)sizeof PL_tokenbuf) - Perl_croak(aTHX_ "Excessively long <> operator"); + Perl_croak(aTHX_ "Excessively long <> operator"); if (s >= end) - Perl_croak(aTHX_ "Unterminated <> operator"); + Perl_croak(aTHX_ "Unterminated <> operator"); s++; @@ -11040,7 +11040,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* allow or */ while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') { - d += UTF ? UTF8SKIP(d) : 1; + d += UTF ? UTF8SKIP(d) : 1; } /* If we've tried to read what we allow filehandles to look like, and @@ -11050,91 +11050,91 @@ S_scan_inputsymbol(pTHX_ char *start) */ if (d - PL_tokenbuf != len) { - pl_yylval.ival = OP_GLOB; - s = scan_str(start,FALSE,FALSE,FALSE,NULL); - if (!s) - Perl_croak(aTHX_ "Glob not terminated"); - return s; + pl_yylval.ival = OP_GLOB; + s = scan_str(start,FALSE,FALSE,FALSE,NULL); + if (!s) + Perl_croak(aTHX_ "Glob not terminated"); + return s; } else { - bool readline_overriden = FALSE; - GV *gv_readline; - /* we're in a filehandle read situation */ - d = PL_tokenbuf; - - /* turn <> into */ - if (!len) - Copy("ARGV",d,5,char); - - /* Check whether readline() is overriden */ - if ((gv_readline = gv_override("readline",8))) - readline_overriden = TRUE; - - /* if <$fh>, create the ops to turn the variable into a - filehandle - */ - if (*d == '$') { - /* try to find it in the pad for this block, otherwise find - add symbol table ops - */ - const PADOFFSET tmp = pad_findmy_pvn(d, len, 0); - if (tmp != NOT_IN_PAD) { - if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { - HV * const stash = PAD_COMPNAME_OURSTASH(tmp); - HEK * const stashname = HvNAME_HEK(stash); - SV * const sym = sv_2mortal(newSVhek(stashname)); - sv_catpvs(sym, "::"); - sv_catpv(sym, d+1); - d = SvPVX(sym); - goto intro_sym; - } - else { - OP * const o = newOP(OP_PADSV, 0); - o->op_targ = tmp; - PL_lex_op = readline_overriden + bool readline_overriden = FALSE; + GV *gv_readline; + /* we're in a filehandle read situation */ + d = PL_tokenbuf; + + /* turn <> into */ + if (!len) + Copy("ARGV",d,5,char); + + /* Check whether readline() is overriden */ + if ((gv_readline = gv_override("readline",8))) + readline_overriden = TRUE; + + /* if <$fh>, create the ops to turn the variable into a + filehandle + */ + if (*d == '$') { + /* try to find it in the pad for this block, otherwise find + add symbol table ops + */ + const PADOFFSET tmp = pad_findmy_pvn(d, len, 0); + if (tmp != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { + HV * const stash = PAD_COMPNAME_OURSTASH(tmp); + HEK * const stashname = HvNAME_HEK(stash); + SV * const sym = sv_2mortal(newSVhek(stashname)); + sv_catpvs(sym, "::"); + sv_catpv(sym, d+1); + d = SvPVX(sym); + goto intro_sym; + } + else { + OP * const o = newOP(OP_PADSV, 0); + o->op_targ = tmp; + PL_lex_op = readline_overriden ? newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, o, - newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) + op_append_elem(OP_LIST, o, + newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) : newUNOP(OP_READLINE, 0, o); - } - } - else { - GV *gv; - ++d; + } + } + else { + GV *gv; + ++d; intro_sym: - gv = gv_fetchpv(d, - GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ), - SVt_PV); - PL_lex_op = readline_overriden + gv = gv_fetchpv(d, + GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ), + SVt_PV); + PL_lex_op = readline_overriden ? newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, - newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), - newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) + op_append_elem(OP_LIST, + newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), + newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) : newUNOP(OP_READLINE, 0, - newUNOP(OP_RV2SV, 0, - newGVOP(OP_GV, 0, gv))); - } - /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */ - pl_yylval.ival = OP_NULL; - } - - /* If it's none of the above, it must be a literal filehandle - ( or ) so build a simple readline OP */ - else { - GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO); - PL_lex_op = readline_overriden + newUNOP(OP_RV2SV, 0, + newGVOP(OP_GV, 0, gv))); + } + /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */ + pl_yylval.ival = OP_NULL; + } + + /* If it's none of the above, it must be a literal filehandle + ( or ) so build a simple readline OP */ + else { + GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO); + PL_lex_op = readline_overriden ? newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, - newGVOP(OP_GV, 0, gv), - newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) + op_append_elem(OP_LIST, + newGVOP(OP_GV, 0, gv), + newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv)); - pl_yylval.ival = OP_NULL; + pl_yylval.ival = OP_NULL; /* leave the token generation above to avoid confusing the parser */ if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) { no_bareword_filehandle(d); } - } + } } return s; @@ -11143,36 +11143,36 @@ S_scan_inputsymbol(pTHX_ char *start) /* scan_str takes: - start position in buffer + start position in buffer keep_bracketed_quoted preserve \ quoting of embedded delimiters, but only if they are of the open/close form - keep_delims preserve the delimiters around the string - re_reparse compiling a run-time /(?{})/: - collapse // to /, and skip encoding src - delimp if non-null, this is set to the position of - the closing delimiter, or just after it if - the closing and opening delimiters differ - (i.e., the opening delimiter of a substitu- - tion replacement) + keep_delims preserve the delimiters around the string + re_reparse compiling a run-time /(?{})/: + collapse // to /, and skip encoding src + delimp if non-null, this is set to the position of + the closing delimiter, or just after it if + the closing and opening delimiters differ + (i.e., the opening delimiter of a substitu- + tion replacement) returns: position to continue reading from buffer side-effects: multi_start, multi_close, lex_repl or lex_stuff, and - updates the read buffer. + updates the read buffer. This subroutine pulls a string out of the input. It is called for: - q single quotes q(literal text) - ' single quotes 'literal text' - qq double quotes qq(interpolate $here please) - " double quotes "interpolate $here please" - qx backticks qx(/bin/ls -l) - ` backticks `/bin/ls -l` - qw quote words @EXPORT_OK = qw( func() $spam ) - m// regexp match m/this/ - s/// regexp substitute s/this/that/ - tr/// string transliterate tr/this/that/ - y/// string transliterate y/this/that/ - ($*@) sub prototypes sub foo ($) - (stuff) sub attr parameters sub foo : attr(stuff) - <> readline or globs , <>, <$fh>, or <*.c> + q single quotes q(literal text) + ' single quotes 'literal text' + qq double quotes qq(interpolate $here please) + " double quotes "interpolate $here please" + qx backticks qx(/bin/ls -l) + ` backticks `/bin/ls -l` + qw quote words @EXPORT_OK = qw( func() $spam ) + m// regexp match m/this/ + s/// regexp substitute s/this/that/ + tr/// string transliterate tr/this/that/ + y/// string transliterate y/this/that/ + ($*@) sub prototypes sub foo ($) + (stuff) sub attr parameters sub foo : attr(stuff) + <> readline or globs , <>, <$fh>, or <*.c> In most of these cases (all but <>, patterns and transliterate) yylex() calls scan_str(). m// makes yylex() call scan_pat() which @@ -11195,7 +11195,7 @@ S_scan_inputsymbol(pTHX_ char *start) char * Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse, - char **delimp + char **delimp ) { SV *sv; /* scalar value: string */ @@ -11223,7 +11223,7 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int /* skip space before the delimiter */ if (isSPACE(*s)) { - s = skipspace(s); + s = skipspace(s); } /* mark where we are, in case we need to report errors */ @@ -11232,11 +11232,11 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int /* after skipping whitespace, the next character is the terminator */ term = *s; if (!UTF || UTF8_IS_INVARIANT(term)) { - termcode = termstr[0] = term; - termlen = 1; + termcode = termstr[0] = term; + termlen = 1; } else { - termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen); + termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen); if (UTF && UNLIKELY(! is_grapheme((U8 *) start, (U8 *) s, (U8 *) PL_bufend, @@ -11245,7 +11245,7 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int yyerror(non_grapheme_msg); } - Copy(s, termstr, termlen, U8); + Copy(s, termstr, termlen, U8); } /* mark where we are */ @@ -11273,35 +11273,35 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int /* move past delimiter and try to read a complete string */ if (keep_delims) - sv_catpvn(sv, s, termlen); + sv_catpvn(sv, s, termlen); s += termlen; for (;;) { - /* extend sv if need be */ - SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); - /* set 'to' to the next character in the sv's string */ - to = SvPVX(sv)+SvCUR(sv); - - /* if open delimiter is the close delimiter read unbridle */ - if (PL_multi_open == PL_multi_close) { - for (; s < PL_bufend; s++,to++) { - /* embedded newlines increment the current line number */ - if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) - COPLINE_INC_WITH_HERELINES; - /* handle quoted delimiters */ - if (*s == '\\' && s+1 < PL_bufend && term != '\\') { - if (!keep_bracketed_quoted - && (s[1] == term - || (re_reparse && s[1] == '\\')) - ) - s++; - else /* any other quotes are simply copied straight through */ - *to++ = *s++; - } - /* terminate when run out of buffer (the for() condition), or - have found the terminator */ - else if (*s == term) { /* First byte of terminator matches */ - if (termlen == 1) /* If is the only byte, are done */ - break; + /* extend sv if need be */ + SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); + /* set 'to' to the next character in the sv's string */ + to = SvPVX(sv)+SvCUR(sv); + + /* if open delimiter is the close delimiter read unbridle */ + if (PL_multi_open == PL_multi_close) { + for (; s < PL_bufend; s++,to++) { + /* embedded newlines increment the current line number */ + if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) + COPLINE_INC_WITH_HERELINES; + /* handle quoted delimiters */ + if (*s == '\\' && s+1 < PL_bufend && term != '\\') { + if (!keep_bracketed_quoted + && (s[1] == term + || (re_reparse && s[1] == '\\')) + ) + s++; + else /* any other quotes are simply copied straight through */ + *to++ = *s++; + } + /* terminate when run out of buffer (the for() condition), or + have found the terminator */ + else if (*s == term) { /* First byte of terminator matches */ + if (termlen == 1) /* If is the only byte, are done */ + break; /* If the remainder of the terminator matches, also are * done, after checking that is a separate grapheme */ @@ -11316,96 +11316,96 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int { yyerror(non_grapheme_msg); } - break; + break; } - } - else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) { - d_is_utf8 = TRUE; + } + else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) { + d_is_utf8 = TRUE; } - *to = *s; - } - } - - /* if the terminator isn't the same as the start character (e.g., - matched brackets), we have to allow more in the quoting, and - be prepared for nested brackets. - */ - else { - /* read until we run out of string, or we find the terminator */ - for (; s < PL_bufend; s++,to++) { - /* embedded newlines increment the line count */ - if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) - COPLINE_INC_WITH_HERELINES; - /* backslashes can escape the open or closing characters */ - if (*s == '\\' && s+1 < PL_bufend) { - if (!keep_bracketed_quoted + *to = *s; + } + } + + /* if the terminator isn't the same as the start character (e.g., + matched brackets), we have to allow more in the quoting, and + be prepared for nested brackets. + */ + else { + /* read until we run out of string, or we find the terminator */ + for (; s < PL_bufend; s++,to++) { + /* embedded newlines increment the line count */ + if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) + COPLINE_INC_WITH_HERELINES; + /* backslashes can escape the open or closing characters */ + if (*s == '\\' && s+1 < PL_bufend) { + if (!keep_bracketed_quoted && ( ((UV)s[1] == PL_multi_open) || ((UV)s[1] == PL_multi_close) )) { - s++; + s++; } - else - *to++ = *s++; + else + *to++ = *s++; } - /* allow nested opens and closes */ - else if ((UV)*s == PL_multi_close && --brackets <= 0) - break; - else if ((UV)*s == PL_multi_open) - brackets++; - else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) - d_is_utf8 = TRUE; - *to = *s; - } - } - /* terminate the copied string and update the sv's end-of-string */ - *to = '\0'; - SvCUR_set(sv, to - SvPVX_const(sv)); - - /* - * this next chunk reads more into the buffer if we're not done yet - */ - - if (s < PL_bufend) - break; /* handle case where we are done yet :-) */ + /* allow nested opens and closes */ + else if ((UV)*s == PL_multi_close && --brackets <= 0) + break; + else if ((UV)*s == PL_multi_open) + brackets++; + else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) + d_is_utf8 = TRUE; + *to = *s; + } + } + /* terminate the copied string and update the sv's end-of-string */ + *to = '\0'; + SvCUR_set(sv, to - SvPVX_const(sv)); + + /* + * this next chunk reads more into the buffer if we're not done yet + */ + + if (s < PL_bufend) + break; /* handle case where we are done yet :-) */ #ifndef PERL_STRICT_CR - if (to - SvPVX_const(sv) >= 2) { - if ( (to[-2] == '\r' && to[-1] == '\n') + if (to - SvPVX_const(sv) >= 2) { + if ( (to[-2] == '\r' && to[-1] == '\n') || (to[-2] == '\n' && to[-1] == '\r')) - { - to[-2] = '\n'; - to--; - SvCUR_set(sv, to - SvPVX_const(sv)); - } - else if (to[-1] == '\r') - to[-1] = '\n'; - } - else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') - to[-1] = '\n'; + { + to[-2] = '\n'; + to--; + SvCUR_set(sv, to - SvPVX_const(sv)); + } + else if (to[-1] == '\r') + to[-1] = '\n'; + } + else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') + to[-1] = '\n'; #endif - /* if we're out of file, or a read fails, bail and reset the current - line marker so we can report where the unterminated string began - */ - COPLINE_INC_WITH_HERELINES; - PL_bufptr = PL_bufend; - if (!lex_next_chunk(0)) { - sv_free(sv); - CopLINE_set(PL_curcop, (line_t)PL_multi_start); - return NULL; - } - s = start = PL_bufptr; + /* if we're out of file, or a read fails, bail and reset the current + line marker so we can report where the unterminated string began + */ + COPLINE_INC_WITH_HERELINES; + PL_bufptr = PL_bufend; + if (!lex_next_chunk(0)) { + sv_free(sv); + CopLINE_set(PL_curcop, (line_t)PL_multi_start); + return NULL; + } + s = start = PL_bufptr; } /* at this point, we have successfully read the delimited string */ if (keep_delims) - sv_catpvn(sv, s, termlen); + sv_catpvn(sv, s, termlen); s += termlen; if (d_is_utf8) - SvUTF8_on(sv); + SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_multi_start); @@ -11413,8 +11413,8 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int /* if we allocated too much space, give some back */ if (SvCUR(sv) + 5 < SvLEN(sv)) { - SvLEN_set(sv, SvCUR(sv) + 1); - SvPV_shrink_to_cur(sv); + SvLEN_set(sv, SvCUR(sv) + 1); + SvPV_shrink_to_cur(sv); } /* decide whether this is the first or second quoted string we've read @@ -11422,9 +11422,9 @@ Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int */ if (PL_lex_stuff) - PL_parser->lex_sub_repl = sv; + PL_parser->lex_sub_repl = sv; else - PL_lex_stuff = sv; + PL_lex_stuff = sv; if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s; return s; } @@ -11466,13 +11466,13 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) bool warned_about_underscore = 0; I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */ #define WARN_ABOUT_UNDERSCORE() \ - do { \ - if (!warned_about_underscore) { \ - warned_about_underscore = 1; \ - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \ - "Misplaced _ in number"); \ - } \ - } while(0) + do { \ + if (!warned_about_underscore) { \ + warned_about_underscore = 1; \ + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \ + "Misplaced _ in number"); \ + } \ + } while(0) /* Hexadecimal floating point. * * In many places (where we have quads and NV is IEEE 754 double) @@ -11504,145 +11504,145 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) switch (*s) { default: - Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s); + Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s); /* if it starts with a 0, it could be an octal number, a decimal in 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': - { - /* variables: - u holds the "number so far" - overflowed was the number more than we can hold? - - Shift is used when we add a digit. It also serves as an "are - we in octal/hex/binary?" indicator to disallow hex characters - when in octal mode. - */ - NV n = 0.0; - UV u = 0; - bool overflowed = FALSE; - bool just_zero = TRUE; /* just plain 0 or binary number? */ + { + /* variables: + u holds the "number so far" + overflowed was the number more than we can hold? + + Shift is used when we add a digit. It also serves as an "are + we in octal/hex/binary?" indicator to disallow hex characters + when in octal mode. + */ + NV n = 0.0; + UV u = 0; + bool overflowed = FALSE; + bool just_zero = TRUE; /* just plain 0 or binary number? */ bool has_digs = FALSE; - static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; - static const char* const bases[5] = - { "", "binary", "", "octal", "hexadecimal" }; - static const char* const Bases[5] = - { "", "Binary", "", "Octal", "Hexadecimal" }; - static const char* const maxima[5] = - { "", - "0b11111111111111111111111111111111", - "", - "037777777777", - "0xffffffff" }; - - /* check for hex */ - if (isALPHA_FOLD_EQ(s[1], 'x')) { - shift = 4; - s += 2; - just_zero = FALSE; - } else if (isALPHA_FOLD_EQ(s[1], 'b')) { - shift = 1; - s += 2; - just_zero = FALSE; - } - /* check for a decimal in disguise */ - else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e')) - goto decimal; - /* so it must be octal */ - else { - shift = 3; - s++; + static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; + static const char* const bases[5] = + { "", "binary", "", "octal", "hexadecimal" }; + static const char* const Bases[5] = + { "", "Binary", "", "Octal", "Hexadecimal" }; + static const char* const maxima[5] = + { "", + "0b11111111111111111111111111111111", + "", + "037777777777", + "0xffffffff" }; + + /* check for hex */ + if (isALPHA_FOLD_EQ(s[1], 'x')) { + shift = 4; + s += 2; + just_zero = FALSE; + } else if (isALPHA_FOLD_EQ(s[1], 'b')) { + shift = 1; + s += 2; + just_zero = FALSE; + } + /* check for a decimal in disguise */ + else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e')) + goto decimal; + /* so it must be octal */ + else { + shift = 3; + s++; if (isALPHA_FOLD_EQ(*s, 'o')) { s++; just_zero = FALSE; new_octal = TRUE; } - } - - if (*s == '_') { - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - } - - /* read the rest of the number */ - for (;;) { - /* x is used in the overflow test, - b is the digit we're adding on. */ - UV x, b; - - switch (*s) { - - /* if we don't mention it, we're done */ - default: - goto out; - - /* _ are ignored -- but warned about if consecutive */ - case '_': - if (lastub && s == lastub + 1) - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - break; - - /* 8 and 9 are not octal */ - case '8': case '9': - if (shift == 3) - yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); - /* FALLTHROUGH */ - - /* octal digits */ - case '2': case '3': case '4': - case '5': case '6': case '7': - if (shift == 1) - yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); - /* FALLTHROUGH */ - - case '0': case '1': - b = *s++ & 15; /* ASCII digit -> value of digit */ - goto digit; - - /* hex digits */ - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - /* make sure they said 0x */ - if (shift != 4) - goto out; - b = (*s++ & 7) + 9; - - /* Prepare to put the digit we have onto the end - of the number so far. We check for overflows. - */ - - digit: - just_zero = FALSE; + } + + if (*s == '_') { + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + } + + /* read the rest of the number */ + for (;;) { + /* x is used in the overflow test, + b is the digit we're adding on. */ + UV x, b; + + switch (*s) { + + /* if we don't mention it, we're done */ + default: + goto out; + + /* _ are ignored -- but warned about if consecutive */ + case '_': + if (lastub && s == lastub + 1) + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + break; + + /* 8 and 9 are not octal */ + case '8': case '9': + if (shift == 3) + yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); + /* FALLTHROUGH */ + + /* octal digits */ + case '2': case '3': case '4': + case '5': case '6': case '7': + if (shift == 1) + yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); + /* FALLTHROUGH */ + + case '0': case '1': + b = *s++ & 15; /* ASCII digit -> value of digit */ + goto digit; + + /* hex digits */ + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + /* make sure they said 0x */ + if (shift != 4) + goto out; + b = (*s++ & 7) + 9; + + /* Prepare to put the digit we have onto the end + of the number so far. We check for overflows. + */ + + digit: + just_zero = FALSE; has_digs = TRUE; - if (!overflowed) { - assert(shift >= 0); - x = u << shift; /* make room for the digit */ + if (!overflowed) { + assert(shift >= 0); + x = u << shift; /* make room for the digit */ total_bits += shift; - if ((x >> shift) != u - && !(PL_hints & HINT_NEW_BINARY)) { - overflowed = TRUE; - n = (NV) u; - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in %s number", + if ((x >> shift) != u + && !(PL_hints & HINT_NEW_BINARY)) { + overflowed = TRUE; + n = (NV) u; + Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in %s number", bases[shift]); - } else - u = x | b; /* add the digit to the end */ - } - if (overflowed) { - n *= nvshift[shift]; - /* If an NV has not enough bits in its - * mantissa to represent an UV this summing of - * small low-order numbers is a waste of time - * (because the NV cannot preserve the - * low-order bits anyway): we could just - * remember when did we overflow and in the - * end just multiply n by the right - * amount. */ - n += (NV) b; - } + } else + u = x | b; /* add the digit to the end */ + } + if (overflowed) { + n *= nvshift[shift]; + /* If an NV has not enough bits in its + * mantissa to represent an UV this summing of + * small low-order numbers is a waste of time + * (because the NV cannot preserve the + * low-order bits anyway): we could just + * remember when did we overflow and in the + * end just multiply n by the right + * amount. */ + n += (NV) b; + } if (high_non_zero == 0 && b > 0) high_non_zero = b; @@ -11656,18 +11656,18 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) goto out; } - break; - } - } + break; + } + } - /* if we get here, we had success: make a scalar value from - the number. - */ - out: + /* if we get here, we had success: make a scalar value from + the number. + */ + out: - /* final misplaced underbar check */ - if (s[-1] == '_') - WARN_ABOUT_UNDERSCORE(); + /* final misplaced underbar check */ + if (s[-1] == '_') + WARN_ABOUT_UNDERSCORE(); if (UNLIKELY(HEXFP_PEEK(s))) { /* Do sloppy (on the underbars) but quick detection @@ -11708,7 +11708,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (significant_bits < NV_MANT_DIG) { /* We are in the long "run" of xdigits, * accumulate the full four bits. */ - assert(shift >= 0); + assert(shift >= 0); hexfp_uquad <<= shift; hexfp_uquad |= b; hexfp_frac_bits += shift; @@ -11721,9 +11721,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) significant_bits - NV_MANT_DIG; if (tail <= 0) tail += shift; - assert(tail >= 0); + assert(tail >= 0); hexfp_uquad <<= tail; - assert((shift - tail) >= 0); + assert((shift - tail) >= 0); hexfp_uquad |= b >> (shift - tail); hexfp_frac_bits += tail; @@ -11845,32 +11845,32 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) PL_bufptr = oldbp; } - if (overflowed) { - if (n > 4294967295.0) - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "%s number > %s non-portable", + if (overflowed) { + if (n > 4294967295.0) + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "%s number > %s non-portable", Bases[shift], new_octal ? "0o37777777777" : maxima[shift]); - sv = newSVnv(n); - } - else { + sv = newSVnv(n); + } + else { #if UVSIZE > 4 - if (u > 0xffffffff) - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "%s number > %s non-portable", + if (u > 0xffffffff) + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "%s number > %s non-portable", Bases[shift], new_octal ? "0o37777777777" : maxima[shift]); #endif - sv = newSVuv(u); - } - if (just_zero && (PL_hints & HINT_NEW_INTEGER)) - sv = new_constant(start, s - start, "integer", - sv, NULL, NULL, 0, NULL); - else if (PL_hints & HINT_NEW_BINARY) - sv = new_constant(start, s - start, "binary", + sv = newSVuv(u); + } + if (just_zero && (PL_hints & HINT_NEW_INTEGER)) + sv = new_constant(start, s - start, "integer", + sv, NULL, NULL, 0, NULL); + else if (PL_hints & HINT_NEW_BINARY) + sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0, NULL); - } - break; + } + break; /* handle decimal numbers. @@ -11879,8 +11879,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': decimal: - d = PL_tokenbuf; - e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ + d = PL_tokenbuf; + e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ floatit = FALSE; if (hexfp) { floatit = TRUE; @@ -11907,75 +11907,75 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } } - /* read next group of digits and _ and copy into d */ - while (isDIGIT(*s) + /* read next group of digits and _ and copy into d */ + while (isDIGIT(*s) || *s == '_' || UNLIKELY(hexfp && isXDIGIT(*s))) { - /* skip underscores, checking for misplaced ones - if -w is on - */ - if (*s == '_') { - if (lastub && s == lastub + 1) - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - } - else { - /* check for end of fixed-length buffer */ - if (d >= e) - Perl_croak(aTHX_ "%s", number_too_long); - /* if we're ok, copy the character */ - *d++ = *s++; - } - } - - /* final misplaced underbar check */ - if (lastub && s == lastub + 1) - WARN_ABOUT_UNDERSCORE(); - - /* read a decimal portion if there is one. avoid - 3..5 being interpreted as the number 3. followed - by .5 - */ - if (*s == '.' && s[1] != '.') { - floatit = TRUE; - *d++ = *s++; - - if (*s == '_') { - WARN_ABOUT_UNDERSCORE(); - lastub = s; - } - - /* copy, ignoring underbars, until we run out of digits. - */ - for (; isDIGIT(*s) + /* skip underscores, checking for misplaced ones + if -w is on + */ + if (*s == '_') { + if (lastub && s == lastub + 1) + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + } + else { + /* check for end of fixed-length buffer */ + if (d >= e) + Perl_croak(aTHX_ "%s", number_too_long); + /* if we're ok, copy the character */ + *d++ = *s++; + } + } + + /* final misplaced underbar check */ + if (lastub && s == lastub + 1) + WARN_ABOUT_UNDERSCORE(); + + /* read a decimal portion if there is one. avoid + 3..5 being interpreted as the number 3. followed + by .5 + */ + if (*s == '.' && s[1] != '.') { + floatit = TRUE; + *d++ = *s++; + + if (*s == '_') { + WARN_ABOUT_UNDERSCORE(); + lastub = s; + } + + /* copy, ignoring underbars, until we run out of digits. + */ + for (; isDIGIT(*s) || *s == '_' || UNLIKELY(hexfp && isXDIGIT(*s)); s++) { - /* fixed length buffer check */ - if (d >= e) - Perl_croak(aTHX_ "%s", number_too_long); - if (*s == '_') { - if (lastub && s == lastub + 1) - WARN_ABOUT_UNDERSCORE(); - lastub = s; - } - else - *d++ = *s; - } - /* fractional part ending in underbar? */ - if (s[-1] == '_') - WARN_ABOUT_UNDERSCORE(); - if (*s == '.' && isDIGIT(s[1])) { - /* oops, it's really a v-string, but without the "v" */ - s = start; - goto vstring; - } - } - - /* read exponent part, if present */ - if ((isALPHA_FOLD_EQ(*s, 'e') + /* fixed length buffer check */ + if (d >= e) + Perl_croak(aTHX_ "%s", number_too_long); + if (*s == '_') { + if (lastub && s == lastub + 1) + WARN_ABOUT_UNDERSCORE(); + lastub = s; + } + else + *d++ = *s; + } + /* fractional part ending in underbar? */ + if (s[-1] == '_') + WARN_ABOUT_UNDERSCORE(); + if (*s == '.' && isDIGIT(s[1])) { + /* oops, it's really a v-string, but without the "v" */ + s = start; + goto vstring; + } + } + + /* read exponent part, if present */ + if ((isALPHA_FOLD_EQ(*s, 'e') || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p'))) && memCHRs("+-0123456789_", s[1])) { @@ -11986,47 +11986,47 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* regardless of whether user said 3E5 or 3e5, use lower 'e', ditto for p (hexfloats) */ if ((isALPHA_FOLD_EQ(*s, 'e'))) { - /* At least some Mach atof()s don't grok 'E' */ + /* At least some Mach atof()s don't grok 'E' */ *d++ = 'e'; } else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) { *d++ = 'p'; } - s++; + s++; - /* stray preinitial _ */ - if (*s == '_') { - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - } + /* stray preinitial _ */ + if (*s == '_') { + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + } - /* allow positive or negative exponent */ - if (*s == '+' || *s == '-') - *d++ = *s++; + /* allow positive or negative exponent */ + if (*s == '+' || *s == '-') + *d++ = *s++; - /* stray initial _ */ - if (*s == '_') { - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - } + /* stray initial _ */ + if (*s == '_') { + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + } - /* read digits of exponent */ - while (isDIGIT(*s) || *s == '_') { - if (isDIGIT(*s)) { + /* read digits of exponent */ + while (isDIGIT(*s) || *s == '_') { + if (isDIGIT(*s)) { ++exp_digits; - if (d >= e) - Perl_croak(aTHX_ "%s", number_too_long); - *d++ = *s++; - } - else { - if (((lastub && s == lastub + 1) + if (d >= e) + Perl_croak(aTHX_ "%s", number_too_long); + *d++ = *s++; + } + else { + if (((lastub && s == lastub + 1) || (!isDIGIT(s[1]) && s[1] != '_'))) - WARN_ABOUT_UNDERSCORE(); - lastub = s++; - } - } + WARN_ABOUT_UNDERSCORE(); + lastub = s++; + } + } if (!exp_digits) { /* no exponent digits, the [eEpP] could be for something else, @@ -12041,34 +12041,34 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) else { floatit = TRUE; } - } + } - /* + /* We try to do an integer conversion first if no characters indicating "float" have been found. - */ + */ - if (!floatit) { - UV uv; - const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); + if (!floatit) { + UV uv; + const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); if (flags == IS_NUMBER_IN_UV) { if (uv <= IV_MAX) - sv = newSViv(uv); /* Prefer IVs over UVs. */ + sv = newSViv(uv); /* Prefer IVs over UVs. */ else - sv = newSVuv(uv); + sv = newSVuv(uv); } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) { if (uv <= (UV) IV_MIN) sv = newSViv(-(IV)uv); else - floatit = TRUE; + floatit = TRUE; } else floatit = TRUE; } - if (floatit) { - /* terminate the string */ - *d = '\0'; + if (floatit) { + /* terminate the string */ + *d = '\0'; if (UNLIKELY(hexfp)) { # ifdef NV_MANT_DIG if (significant_bits > NV_MANT_DIG) @@ -12084,35 +12084,35 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) nv = Atof(PL_tokenbuf); } sv = newSVnv(nv); - } + } - if ( floatit - ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) { - const char *const key = floatit ? "float" : "integer"; - const STRLEN keylen = floatit ? 5 : 7; - sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf, - key, keylen, sv, NULL, NULL, 0, NULL); - } - break; + if ( floatit + ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) { + const char *const key = floatit ? "float" : "integer"; + const STRLEN keylen = floatit ? 5 : 7; + sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf, + key, keylen, sv, NULL, NULL, 0, NULL); + } + break; /* if it starts with a v, it could be a v-string */ case 'v': vstring: - sv = newSV(5); /* preallocate storage space */ - ENTER_with_name("scan_vstring"); - SAVEFREESV(sv); - s = scan_vstring(s, PL_bufend, sv); - SvREFCNT_inc_simple_void_NN(sv); - LEAVE_with_name("scan_vstring"); - break; + sv = newSV(5); /* preallocate storage space */ + ENTER_with_name("scan_vstring"); + SAVEFREESV(sv); + s = scan_vstring(s, PL_bufend, sv); + SvREFCNT_inc_simple_void_NN(sv); + LEAVE_with_name("scan_vstring"); + break; } /* make the op for the constant and return */ if (sv) - lvalp->opval = newSVOP(OP_CONST, 0, sv); + lvalp->opval = newSVOP(OP_CONST, 0, sv); else - lvalp->opval = NULL; + lvalp->opval = NULL; return (char *)s; } @@ -12128,89 +12128,89 @@ S_scan_formline(pTHX_ char *s) while (!needargs) { char *eol; - if (*s == '.') { + if (*s == '.') { char *t = s+1; #ifdef PERL_STRICT_CR - while (SPACE_OR_TAB(*t)) - t++; + while (SPACE_OR_TAB(*t)) + t++; #else - while (SPACE_OR_TAB(*t) || *t == '\r') - t++; + while (SPACE_OR_TAB(*t) || *t == '\r') + t++; #endif - if (*t == '\n' || t == PL_bufend) { - eofmt = TRUE; - break; - } - } - eol = (char *) memchr(s,'\n',PL_bufend-s); - if (!eol++) - eol = PL_bufend; - if (*s != '#') { + if (*t == '\n' || t == PL_bufend) { + eofmt = TRUE; + break; + } + } + eol = (char *) memchr(s,'\n',PL_bufend-s); + if (!eol++) + eol = PL_bufend; + if (*s != '#') { char *t; - for (t = s; t < eol; t++) { - if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { - needargs = FALSE; - goto enough; /* ~~ must be first line in formline */ - } - if (*t == '@' || *t == '^') - needargs = TRUE; - } - if (eol > s) { - sv_catpvn(stuff, s, eol-s); + for (t = s; t < eol; t++) { + if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { + needargs = FALSE; + goto enough; /* ~~ must be first line in formline */ + } + if (*t == '@' || *t == '^') + needargs = TRUE; + } + if (eol > s) { + sv_catpvn(stuff, s, eol-s); #ifndef PERL_STRICT_CR - if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { - char *end = SvPVX(stuff) + SvCUR(stuff); - end[-2] = '\n'; - end[-1] = '\0'; - SvCUR_set(stuff, SvCUR(stuff) - 1); - } + if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { + char *end = SvPVX(stuff) + SvCUR(stuff); + end[-2] = '\n'; + end[-1] = '\0'; + SvCUR_set(stuff, SvCUR(stuff) - 1); + } #endif - } - else - break; - } - s = (char*)eol; - if ((PL_rsfp || PL_parser->filtered) - && PL_parser->form_lex_state == LEX_NORMAL) { - bool got_some; - PL_bufptr = PL_bufend; - COPLINE_INC_WITH_HERELINES; - got_some = lex_next_chunk(0); - CopLINE_dec(PL_curcop); - s = PL_bufptr; - if (!got_some) - break; - } - incline(s, PL_bufend); + } + else + break; + } + s = (char*)eol; + if ((PL_rsfp || PL_parser->filtered) + && PL_parser->form_lex_state == LEX_NORMAL) { + bool got_some; + PL_bufptr = PL_bufend; + COPLINE_INC_WITH_HERELINES; + got_some = lex_next_chunk(0); + CopLINE_dec(PL_curcop); + s = PL_bufptr; + if (!got_some) + break; + } + incline(s, PL_bufend); } enough: if (!SvCUR(stuff) || needargs) - PL_lex_state = PL_parser->form_lex_state; + PL_lex_state = PL_parser->form_lex_state; if (SvCUR(stuff)) { - PL_expect = XSTATE; - if (needargs) { - const char *s2 = s; - while (isSPACE(*s2) && *s2 != '\n') - s2++; - if (*s2 == '{') { - PL_expect = XTERMBLOCK; - NEXTVAL_NEXTTOKE.ival = 0; - force_next(DO); - } - NEXTVAL_NEXTTOKE.ival = 0; - force_next(FORMLBRACK); - } - if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) - SvUTF8_on(stuff); - } + PL_expect = XSTATE; + if (needargs) { + const char *s2 = s; + while (isSPACE(*s2) && *s2 != '\n') + s2++; + if (*s2 == '{') { + PL_expect = XTERMBLOCK; + NEXTVAL_NEXTTOKE.ival = 0; + force_next(DO); + } + NEXTVAL_NEXTTOKE.ival = 0; + force_next(FORMLBRACK); + } + if (!IN_BYTES) { + if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) + SvUTF8_on(stuff); + } NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff); - force_next(THING); + force_next(THING); } else { - SvREFCNT_dec(stuff); - if (eofmt) - PL_lex_formbrack = 0; + SvREFCNT_dec(stuff); + if (eofmt) + PL_lex_formbrack = 0; } return s; } @@ -12233,7 +12233,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; if (outsidecv && CvPADLIST(outsidecv)) - CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id; + CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id; return oldsavestack_ix; } @@ -12428,7 +12428,7 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) const char * msg = ""; const char * const name = OutCopFILE(PL_curcop); - if (PL_in_eval) { + if (PL_in_eval) { SV * errsv = ERRSV; if (SvCUR(errsv)) { msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv)); @@ -12456,41 +12456,41 @@ S_swallow_bom(pTHX_ U8 *s) switch (s[0]) { case 0xFF: - if (s[1] == 0xFE) { - /* UTF-16 little-endian? (or UTF-32LE?) */ - if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE"); + if (s[1] == 0xFE) { + /* UTF-16 little-endian? (or UTF-32LE?) */ + if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE"); #ifndef PERL_NO_UTF16_FILTER #ifdef DEBUGGING - if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n"); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n"); #endif - s += 2; - if (PL_bufend > (char*)s) { - s = add_utf16_textfilter(s, TRUE); - } + s += 2; + if (PL_bufend > (char*)s) { + s = add_utf16_textfilter(s, TRUE); + } #else - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); #endif - } - break; + } + break; case 0xFE: - if (s[1] == 0xFF) { /* UTF-16 big-endian? */ + if (s[1] == 0xFF) { /* UTF-16 big-endian? */ #ifndef PERL_NO_UTF16_FILTER #ifdef DEBUGGING - if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); #endif - s += 2; - if (PL_bufend > (char *)s) { - s = add_utf16_textfilter(s, FALSE); - } + s += 2; + if (PL_bufend > (char *)s) { + s = add_utf16_textfilter(s, FALSE); + } #else - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); #endif - } - break; + } + break; case BOM_UTF8_FIRST_BYTE: { if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) { #ifdef DEBUGGING @@ -12501,46 +12501,46 @@ S_swallow_bom(pTHX_ U8 *s) break; } case 0: - if (slen > 3) { - if (s[1] == 0) { - if (s[2] == 0xFE && s[3] == 0xFF) { - /* UTF-32 big-endian */ - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE"); - } - } - else if (s[2] == 0 && s[3] != 0) { - /* Leading bytes - * 00 xx 00 xx - * are a good indicator of UTF-16BE. */ + if (slen > 3) { + if (s[1] == 0) { + if (s[2] == 0xFE && s[3] == 0xFF) { + /* UTF-32 big-endian */ + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE"); + } + } + else if (s[2] == 0 && s[3] != 0) { + /* Leading bytes + * 00 xx 00 xx + * are a good indicator of UTF-16BE. */ #ifndef PERL_NO_UTF16_FILTER #ifdef DEBUGGING - if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); #endif - s = add_utf16_textfilter(s, FALSE); + s = add_utf16_textfilter(s, FALSE); #else - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); #endif - } - } + } + } break; default: - if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { - /* Leading bytes - * xx 00 xx 00 - * are a good indicator of UTF-16LE. */ + if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { + /* Leading bytes + * xx 00 xx 00 + * are a good indicator of UTF-16LE. */ #ifndef PERL_NO_UTF16_FILTER #ifdef DEBUGGING - if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); #endif - s = add_utf16_textfilter(s, TRUE); + s = add_utf16_textfilter(s, TRUE); #else - /* diag_listed_as: Unsupported script encoding %s */ - Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); + /* diag_listed_as: Unsupported script encoding %s */ + Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); #endif - } + } } return (char*)s; } @@ -12565,111 +12565,111 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) from this file, we can be sure that we're not called in block mode. Hence don't bother writing code to deal with block mode. */ if (maxlen) { - Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen); + Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen); } if (status < 0) { - Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status); + Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status); } DEBUG_P(PerlIO_printf(Perl_debug_log, - "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n", - FPTR2DPTR(void *, S_utf16_textfilter), - reverse ? 'l' : 'b', idx, maxlen, status, - (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); + "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n", + FPTR2DPTR(void *, S_utf16_textfilter), + reverse ? 'l' : 'b', idx, maxlen, status, + (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); while (1) { - STRLEN chars; - STRLEN have; - Size_t newlen; - U8 *end; - /* First, look in our buffer of existing UTF-8 data: */ - char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer)); - - if (nl) { - ++nl; - } else if (status == 0) { - /* EOF */ - IoPAGE(filter) = 0; - nl = SvEND(utf8_buffer); - } - if (nl) { - STRLEN got = nl - SvPVX(utf8_buffer); - /* Did we have anything to append? */ - retval = got != 0; - sv_catpvn(sv, SvPVX(utf8_buffer), got); - /* Everything else in this code works just fine if SVp_POK isn't - set. This, however, needs it, and we need it to work, else - we loop infinitely because the buffer is never consumed. */ - sv_chop(utf8_buffer, nl); - break; - } - - /* OK, not a complete line there, so need to read some more UTF-16. - Read an extra octect if the buffer currently has an odd number. */ - while (1) { - if (status <= 0) - break; - if (SvCUR(utf16_buffer) >= 2) { - /* Location of the high octet of the last complete code point. - Gosh, UTF-16 is a pain. All the benefits of variable length, - *coupled* with all the benefits of partial reads and - endianness. */ - const U8 *const last_hi = (U8*)SvPVX(utf16_buffer) - + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2)); - - if (*last_hi < 0xd8 || *last_hi > 0xdb) { - break; - } - - /* We have the first half of a surrogate. Read more. */ - DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi)); - } - - status = FILTER_READ(idx + 1, utf16_buffer, - 160 + (SvCUR(utf16_buffer) & 1)); - DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer))); - DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);}); - if (status < 0) { - /* Error */ - IoPAGE(filter) = status; - return status; - } - } + STRLEN chars; + STRLEN have; + Size_t newlen; + U8 *end; + /* First, look in our buffer of existing UTF-8 data: */ + char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer)); + + if (nl) { + ++nl; + } else if (status == 0) { + /* EOF */ + IoPAGE(filter) = 0; + nl = SvEND(utf8_buffer); + } + if (nl) { + STRLEN got = nl - SvPVX(utf8_buffer); + /* Did we have anything to append? */ + retval = got != 0; + sv_catpvn(sv, SvPVX(utf8_buffer), got); + /* Everything else in this code works just fine if SVp_POK isn't + set. This, however, needs it, and we need it to work, else + we loop infinitely because the buffer is never consumed. */ + sv_chop(utf8_buffer, nl); + break; + } + + /* OK, not a complete line there, so need to read some more UTF-16. + Read an extra octect if the buffer currently has an odd number. */ + while (1) { + if (status <= 0) + break; + if (SvCUR(utf16_buffer) >= 2) { + /* Location of the high octet of the last complete code point. + Gosh, UTF-16 is a pain. All the benefits of variable length, + *coupled* with all the benefits of partial reads and + endianness. */ + const U8 *const last_hi = (U8*)SvPVX(utf16_buffer) + + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2)); + + if (*last_hi < 0xd8 || *last_hi > 0xdb) { + break; + } + + /* We have the first half of a surrogate. Read more. */ + DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi)); + } + + status = FILTER_READ(idx + 1, utf16_buffer, + 160 + (SvCUR(utf16_buffer) & 1)); + DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer))); + DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);}); + if (status < 0) { + /* Error */ + IoPAGE(filter) = status; + return status; + } + } /* 'chars' isn't quite the right name, as code points above 0xFFFF * require 4 bytes per char */ - chars = SvCUR(utf16_buffer) >> 1; - have = SvCUR(utf8_buffer); + chars = SvCUR(utf16_buffer) >> 1; + have = SvCUR(utf8_buffer); /* Assume the worst case size as noted by the functions: twice the * number of input bytes */ - SvGROW(utf8_buffer, have + chars * 4 + 1); - - if (reverse) { - end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer), - (U8*)SvPVX_const(utf8_buffer) + have, - chars * 2, &newlen); - } else { - end = utf16_to_utf8((U8*)SvPVX(utf16_buffer), - (U8*)SvPVX_const(utf8_buffer) + have, - chars * 2, &newlen); - } - SvCUR_set(utf8_buffer, have + newlen); - *end = '\0'; - - /* No need to keep this SV "well-formed" with a '\0' after the end, as - it's private to us, and utf16_to_utf8{,reversed} take a - (pointer,length) pair, rather than a NUL-terminated string. */ - if(SvCUR(utf16_buffer) & 1) { - *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1]; - SvCUR_set(utf16_buffer, 1); - } else { - SvCUR_set(utf16_buffer, 0); - } + SvGROW(utf8_buffer, have + chars * 4 + 1); + + if (reverse) { + end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer), + (U8*)SvPVX_const(utf8_buffer) + have, + chars * 2, &newlen); + } else { + end = utf16_to_utf8((U8*)SvPVX(utf16_buffer), + (U8*)SvPVX_const(utf8_buffer) + have, + chars * 2, &newlen); + } + SvCUR_set(utf8_buffer, have + newlen); + *end = '\0'; + + /* No need to keep this SV "well-formed" with a '\0' after the end, as + it's private to us, and utf16_to_utf8{,reversed} take a + (pointer,length) pair, rather than a NUL-terminated string. */ + if(SvCUR(utf16_buffer) & 1) { + *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1]; + SvCUR_set(utf16_buffer, 1); + } else { + SvCUR_set(utf16_buffer, 0); + } } DEBUG_P(PerlIO_printf(Perl_debug_log, - "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n", - status, - (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); + "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n", + status, + (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);}); return retval; } @@ -12690,9 +12690,9 @@ S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed) ignore any error return from this. */ SvCUR_set(PL_linestr, 0); if (FILTER_READ(0, PL_linestr, 0)) { - SvUTF8_on(PL_linestr); + SvUTF8_on(PL_linestr); } else { - SvUTF8_on(PL_linestr); + SvUTF8_on(PL_linestr); } PL_bufend = SvEND(PL_linestr); return (U8*)SvPVX(PL_linestr); @@ -12705,8 +12705,8 @@ vstring, as well as updating the passed in sv. Function must be called like - sv = sv_2mortal(newSV(5)); - s = scan_vstring(s,e,sv); + sv = sv_2mortal(newSV(5)); + s = scan_vstring(s,e,sv); where s and e are the start and end of the string. The sv should already be large enough to store the vstring @@ -12729,69 +12729,69 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) if (*pos == 'v') pos++; /* get past 'v' */ while (pos < e && (isDIGIT(*pos) || *pos == '_')) - pos++; + pos++; if ( *pos != '.') { - /* this may not be a v-string if followed by => */ - const char *next = pos; - while (next < e && isSPACE(*next)) - ++next; - if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) { - /* return string not v-string */ - sv_setpvn(sv,(char *)s,pos-s); - return (char *)pos; - } + /* this may not be a v-string if followed by => */ + const char *next = pos; + while (next < e && isSPACE(*next)) + ++next; + if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) { + /* return string not v-string */ + sv_setpvn(sv,(char *)s,pos-s); + return (char *)pos; + } } if (!isALPHA(*pos)) { - U8 tmpbuf[UTF8_MAXBYTES+1]; + U8 tmpbuf[UTF8_MAXBYTES+1]; - if (*s == 'v') - s++; /* get past 'v' */ + if (*s == 'v') + s++; /* get past 'v' */ SvPVCLEAR(sv); - for (;;) { - /* this is atoi() that tolerates underscores */ - U8 *tmpend; - UV rev = 0; - const char *end = pos; - UV mult = 1; - while (--end >= s) { - if (*end != '_') { - const UV orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev) - /* diag_listed_as: Integer overflow in %s number */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in decimal number"); - } - } - - /* Append native character for the rev point */ - tmpend = uvchr_to_utf8(tmpbuf, rev); - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!UVCHR_IS_INVARIANT(rev)) - SvUTF8_on(sv); - if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (pos < e && (isDIGIT(*pos) || *pos == '_')) - pos++; - } - SvPOK_on(sv); - sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); - SvRMAGICAL_on(sv); + for (;;) { + /* this is atoi() that tolerates underscores */ + U8 *tmpend; + UV rev = 0; + const char *end = pos; + UV mult = 1; + while (--end >= s) { + if (*end != '_') { + const UV orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if (orev > rev) + /* diag_listed_as: Integer overflow in %s number */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in decimal number"); + } + } + + /* Append native character for the rev point */ + tmpend = uvchr_to_utf8(tmpbuf, rev); + sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + if (!UVCHR_IS_INVARIANT(rev)) + SvUTF8_on(sv); + if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1])) + s = ++pos; + else { + s = pos; + break; + } + while (pos < e && (isDIGIT(*pos) || *pos == '_')) + pos++; + } + SvPOK_on(sv); + sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); + SvRMAGICAL_on(sv); } return (char *)s; } int Perl_keyword_plugin_standard(pTHX_ - char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) + char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD; PERL_UNUSED_CONTEXT; @@ -12879,14 +12879,14 @@ S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof) { SAVEI32(PL_lex_brackets); if (PL_lex_brackets > 100) - Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); + Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF; SAVEI32(PL_lex_allbrackets); PL_lex_allbrackets = 0; SAVEI8(PL_lex_fakeeof); PL_lex_fakeeof = (U8)fakeeof; if(yyparse(gramtype) && !PL_parser->error_count) - qerror(Perl_mess(aTHX_ "Parse error")); + qerror(Perl_mess(aTHX_ "Parse error")); } #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p) @@ -12909,12 +12909,12 @@ S_parse_expr(pTHX_ I32 fakeeof, U32 flags) { OP *exprop; if (flags & ~PARSE_OPTIONAL) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr"); exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof); if (!exprop && !(flags & PARSE_OPTIONAL)) { - if (!PL_parser->error_count) - qerror(Perl_mess(aTHX_ "Parse error")); - exprop = newOP(OP_NULL, 0); + if (!PL_parser->error_count) + qerror(Perl_mess(aTHX_ "Parse error")); + exprop = newOP(OP_NULL, 0); } return exprop; } @@ -13083,7 +13083,7 @@ OP * Perl_parse_block(pTHX_ U32 flags) { if (flags) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block"); return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER); } @@ -13121,7 +13121,7 @@ OP * Perl_parse_barestmt(pTHX_ U32 flags) { if (flags) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt"); return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER); } @@ -13149,49 +13149,49 @@ SV * Perl_parse_label(pTHX_ U32 flags) { if (flags & ~PARSE_OPTIONAL) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label"); if (PL_nexttoke) { - PL_parser->yychar = yylex(); - if (PL_parser->yychar == LABEL) { - SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv; - PL_parser->yychar = YYEMPTY; - cSVOPx(pl_yylval.opval)->op_sv = NULL; - op_free(pl_yylval.opval); - return labelsv; - } else { - yyunlex(); - goto no_label; - } + PL_parser->yychar = yylex(); + if (PL_parser->yychar == LABEL) { + SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv; + PL_parser->yychar = YYEMPTY; + cSVOPx(pl_yylval.opval)->op_sv = NULL; + op_free(pl_yylval.opval); + return labelsv; + } else { + yyunlex(); + goto no_label; + } } else { - char *s, *t; - STRLEN wlen, bufptr_pos; - lex_read_space(0); - t = s = PL_bufptr; + char *s, *t; + STRLEN wlen, bufptr_pos; + lex_read_space(0); + t = s = PL_bufptr; if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) - goto no_label; - t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen); - if (word_takes_any_delimiter(s, wlen)) - goto no_label; - bufptr_pos = s - SvPVX(PL_linestr); - PL_bufptr = t; - lex_read_space(LEX_KEEP_PREVIOUS); - t = PL_bufptr; - s = SvPVX(PL_linestr) + bufptr_pos; - if (t[0] == ':' && t[1] != ':') { - PL_oldoldbufptr = PL_oldbufptr; - PL_oldbufptr = s; - PL_bufptr = t+1; - return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0); - } else { - PL_bufptr = s; - no_label: - if (flags & PARSE_OPTIONAL) { - return NULL; - } else { - qerror(Perl_mess(aTHX_ "Parse error")); - return newSVpvs("x"); - } - } + goto no_label; + t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen); + if (word_takes_any_delimiter(s, wlen)) + goto no_label; + bufptr_pos = s - SvPVX(PL_linestr); + PL_bufptr = t; + lex_read_space(LEX_KEEP_PREVIOUS); + t = PL_bufptr; + s = SvPVX(PL_linestr) + bufptr_pos; + if (t[0] == ':' && t[1] != ':') { + PL_oldoldbufptr = PL_oldbufptr; + PL_oldbufptr = s; + PL_bufptr = t+1; + return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0); + } else { + PL_bufptr = s; + no_label: + if (flags & PARSE_OPTIONAL) { + return NULL; + } else { + qerror(Perl_mess(aTHX_ "Parse error")); + return newSVpvs("x"); + } + } } } @@ -13226,7 +13226,7 @@ OP * Perl_parse_fullstmt(pTHX_ U32 flags) { if (flags) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt"); return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER); } @@ -13266,11 +13266,11 @@ Perl_parse_stmtseq(pTHX_ U32 flags) OP *stmtseqop; I32 c; if (flags) - Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq"); + Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq"); stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING); c = lex_peek_unichar(0); if (c != -1 && c != /*{*/'}') - qerror(Perl_mess(aTHX_ "Parse error")); + qerror(Perl_mess(aTHX_ "Parse error")); return stmtseqop; }