X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=51f962a4ada289a71305fdc132d0b4d2732849df;hb=06dc7ac6fa597f9446b4a27a32d667bbcbde0453;hp=4bd252c567f1a2d5d5921c3f178efabd804e2e88;hpb=e1548254d1365ef0342d5b64bb1fd1d996c1f70f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 4bd252c..51f962a 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,62 @@ * either way, as the saying is, if you follow me." --the Gaffer */ +/* This file contains the functions that create, manipulate and optimize + * the OP structures that hold a compiled perl program. + * + * A Perl program is compiled into a tree of OPs. Each op contains + * structural pointers (eg to its siblings and the next op in the + * execution sequence), a pointer to the function that would execute the + * op, plus any data specific to that op. For example, an OP_CONST op + * points to the pp_const() function and to an SV containing the constant + * value. When pp_const() is executed, its job is to push that SV onto the + * stack. + * + * OPs are mainly created by the newFOO() functions, which are mainly + * called from the parser (in perly.y) as the code is parsed. For example + * the Perl code $a + $b * $c would cause the equivalent of the following + * to be called (oversimplifying a bit): + * + * newBINOP(OP_ADD, flags, + * newSVREF($a), + * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) + * ) + * + * Note that during the build of miniperl, a temporary copy of this file + * is made, called opmini.c. + */ + +/* +Perl's compiler is essentially a 3-pass compiler with interleaved phases: + + A bottom-up pass + A top-down pass + An execution-order pass + +The bottom-up pass is represented by all the "newOP" routines and +the ck_ routines. The bottom-upness is actually driven by yacc. +So at the point that a ck_ routine fires, we have no idea what the +context is, either upward in the syntax tree, or either forward or +backward in the execution order. (The bottom-up parser builds that +part of the execution order it knows about, but if you follow the "next" +links around, you'll find it's actually a closed loop through the +top level node. + +Whenever the bottom-up parser gets to a node that supplies context to +its components, it invokes that portion of the top-down pass that applies +to that part of the subtree (and marks the top node as processed, so +if a node further up supplies context, it doesn't have to take the +plunge again). As a particular subcase of this, as the new node is +built, it takes all the closed execution loops of its subcomponents +and links them into a new closed loop for the higher level node. But +it's still not the real execution order. + +The actual execution order is not known till we get a grammar reduction +to a top-level unit like a subroutine or file that will be called by +"name" rather than via a "next" pointer. At that point, we can call +into peep() to do that code's portion of the 3rd pass. It has to be +recursive, but it's recursive on basic blocks, not on tree nodes. +*/ #include "EXTERN.h" #define PERL_IN_OP_C @@ -72,8 +128,8 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) void Perl_Slab_Free(pTHX_ void *op) { - I32 **ptr = (I32 **) op; - I32 *slab = ptr[-1]; + I32 * const * const ptr = (I32 **) op; + I32 * const slab = ptr[-1]; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); @@ -90,25 +146,24 @@ Perl_Slab_Free(pTHX_ void *op) } #endif /* - * In the following definition, the ", Nullop" is just to make the compiler + * In the following definition, the ", (OP*)0" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ - ((PL_op_mask && PL_op_mask[type]) \ + ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ - Nullop ) \ + (OP*)0 ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) -STATIC char* +STATIC const char* S_gv_ename(pTHX_ GV *gv) { - STRLEN n_a; - SV* tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, gv, Nullch); - return SvPV(tmpsv,n_a); + SV* const tmpsv = sv_newmortal(); + gv_efullname3(tmpsv, gv, NULL); + return SvPV_nolen_const(tmpsv); } STATIC OP * @@ -120,29 +175,31 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments(pTHX_ OP *o, char *name) +S_too_few_arguments(pTHX_ OP *o, const char *name) { yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); return o; } STATIC OP * -S_too_many_arguments(pTHX_ OP *o, char *name) +S_too_many_arguments(pTHX_ OP *o, const char *name) { yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); return o; } STATIC void -S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid) +S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) { yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", (int)n, name, t, OP_DESC(kid))); } STATIC void -S_no_bareword_allowed(pTHX_ OP *o) +S_no_bareword_allowed(pTHX_ const OP *o) { + if (PL_madskills) + return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", cSVOPo_sv)); @@ -153,14 +210,18 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_allocmy(pTHX_ char *name) { + dVAR; PADOFFSET off; + const bool is_our = (PL_in_my == KEY_our); /* complain about "my $" etc etc */ - if (!(PL_in_my == KEY_our || + if (*name && + !(is_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || - (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2)))) + (name[1] == '_' && (*name == '$' || name[2])))) { + /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ char *p; @@ -184,24 +245,22 @@ Perl_allocmy(pTHX_ char *name) } /* check for duplicate declaration */ - pad_check_dup(name, - (bool)(PL_in_my == KEY_our), - (PL_curstash ? PL_curstash : PL_defstash) - ); + pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); if (PL_in_my_stash && *name != '$') { yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", - name, PL_in_my == KEY_our ? "our" : "my")); + name, is_our ? "our" : "my")); } /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, PL_in_my_stash, - (PL_in_my == KEY_our - ? (PL_curstash ? PL_curstash : PL_defstash) - : Nullhv + (is_our + /* $_ is always in main::, even with our */ + ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) + : NULL ), 0 /* not fake */ ); @@ -213,26 +272,29 @@ Perl_allocmy(pTHX_ char *name) void Perl_op_free(pTHX_ OP *o) { - register OP *kid, *nextkid; + dVAR; OPCODE type; if (!o || o->op_static) return; + type = o->op_type; if (o->op_private & OPpREFCOUNTED) { - switch (o->op_type) { + switch (type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: + { + PADOFFSET refcnt; OP_REFCNT_LOCK; - if (OpREFCNT_dec(o)) { - OP_REFCNT_UNLOCK; + refcnt = OpREFCNT_dec(o); + OP_REFCNT_UNLOCK; + if (refcnt) return; } - OP_REFCNT_UNLOCK; break; default: break; @@ -240,12 +302,12 @@ Perl_op_free(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { + register OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { nextkid = kid->op_sibling; /* Get before next freeing kid */ op_free(kid); } } - type = o->op_type; if (type == OP_NULL) type = (OPCODE)o->op_targ; @@ -256,14 +318,40 @@ Perl_op_free(pTHX_ OP *o) op_clear(o); FreeOp(o); +#ifdef DEBUG_LEAKING_SCALARS + if (PL_op == o) + PL_op = NULL; +#endif } void Perl_op_clear(pTHX_ OP *o) { + dVAR; +#ifdef PERL_MAD + /* if (o->op_madprop && o->op_madprop->mad_next) + abort(); */ + /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with + "modification of a read only value" for a reason I can't fathom why. + It's the "" stringification of $_, where $_ was set to '' in a foreach + loop, but it defies simplification into a small test case. + However, commenting them out has caused ext/List/Util/t/weak.t to fail + the last test. */ + /* + mad_free(o->op_madprop); + o->op_madprop = 0; + */ +#endif + + retry: switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ + if (PL_madskills && o->op_targ != OP_NULL) { + o->op_type = o->op_targ; + o->op_targ = 0; + goto retry; + } case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; break; @@ -286,14 +374,14 @@ Perl_op_clear(pTHX_ OP *o) } #else SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = Nullsv; + cSVOPo->op_sv = NULL; #endif } break; case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = Nullsv; + cSVOPo->op_sv = NULL; #ifdef USE_ITHREADS /** Bug #15654 Even if op_clear does a pad_free for the target of the op, @@ -317,11 +405,11 @@ Perl_op_clear(pTHX_ OP *o) case OP_TRANS: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = Nullsv; + cSVOPo->op_sv = NULL; } else { Safefree(cPVOPo->op_pv); - cPVOPo->op_pv = Nullch; + cPVOPo->op_pv = NULL; } break; case OP_SUBST: @@ -342,25 +430,28 @@ Perl_op_clear(pTHX_ OP *o) case OP_QR: clear_pmop: { - HV *pmstash = PmopSTASH(cPMOPo); - if (pmstash && SvREFCNT(pmstash)) { - PMOP *pmop = HvPMROOT(pmstash); - PMOP *lastpmop = NULL; - while (pmop) { - if (cPMOPo == pmop) { - if (lastpmop) - lastpmop->op_pmnext = pmop->op_pmnext; - else - HvPMROOT(pmstash) = pmop->op_pmnext; - break; + HV * const pmstash = PmopSTASH(cPMOPo); + if (pmstash && !SvIS_FREED(pmstash)) { + MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP *pmop = (PMOP*) mg->mg_obj; + PMOP *lastpmop = NULL; + while (pmop) { + if (cPMOPo == pmop) { + if (lastpmop) + lastpmop->op_pmnext = pmop->op_pmnext; + else + mg->mg_obj = (SV*) pmop->op_pmnext; + break; + } + lastpmop = pmop; + pmop = pmop->op_pmnext; } - lastpmop = pmop; - pmop = pmop->op_pmnext; } } PmopSTASH_free(cPMOPo); } - cPMOPo->op_pmreplroot = Nullop; + cPMOPo->op_pmreplroot = NULL; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared @@ -368,7 +459,7 @@ clear_pmop: * happen before sv_clean_all */ ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); - PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); + PM_SETRE_SAFE(cPMOPo, NULL); #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); @@ -396,11 +487,7 @@ S_cop_free(pTHX_ COP* cop) SvREFCNT_dec(cop->cop_warnings); if (! specialCopIO(cop->cop_io)) { #ifdef USE_ITHREADS -#if 0 - STRLEN len; - char *s = SvPV(cop->cop_io,len); - Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ -#endif + /*EMPTY*/ #else SvREFCNT_dec(cop->cop_io); #endif @@ -410,14 +497,32 @@ S_cop_free(pTHX_ COP* cop) void Perl_op_null(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_NULL) return; - op_clear(o); + if (!PL_madskills) + op_clear(o); o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; } +void +Perl_op_refcnt_lock(pTHX) +{ + dVAR; + PERL_UNUSED_CONTEXT; + OP_REFCNT_LOCK; +} + +void +Perl_op_refcnt_unlock(pTHX) +{ + dVAR; + PERL_UNUSED_CONTEXT; + OP_REFCNT_UNLOCK; +} + /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) @@ -425,19 +530,25 @@ Perl_op_null(pTHX_ OP *o) OP * Perl_linklist(pTHX_ OP *o) { - register OP *kid; + OP *first; if (o->op_next) return o->op_next; /* establish postfix order */ - if (cUNOPo->op_first) { - o->op_next = LINKLIST(cUNOPo->op_first); - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) + first = cUNOPo->op_first; + if (first) { + register OP *kid; + o->op_next = LINKLIST(first); + kid = first; + for (;;) { + if (kid->op_sibling) { kid->op_next = LINKLIST(kid->op_sibling); - else + kid = kid->op_sibling; + } else { kid->op_next = o; + break; + } } } else @@ -449,8 +560,8 @@ Perl_linklist(pTHX_ OP *o) OP * Perl_scalarkids(pTHX_ OP *o) { - OP *kid; if (o && o->op_flags & OPf_KIDS) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } @@ -460,9 +571,10 @@ Perl_scalarkids(pTHX_ OP *o) STATIC OP * S_scalarboolean(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { if (ckWARN(WARN_SYNTAX)) { - line_t oldline = CopLINE(PL_curcop); + const line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); @@ -476,10 +588,11 @@ S_scalarboolean(pTHX_ OP *o) OP * Perl_scalar(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ - if (!o || (o->op_flags & OPf_WANT) || PL_error_count + if (!o || PL_error_count || (o->op_flags & OPf_WANT) || o->op_type == OP_RETURN) { return o; @@ -546,11 +659,27 @@ Perl_scalar(pTHX_ OP *o) OP * Perl_scalarvoid(pTHX_ OP *o) { + dVAR; OP *kid; - char* useless = 0; + const char* useless = NULL; SV* sv; U8 want; + /* trailing mad null ops don't count as "there" for void processing */ + if (PL_madskills && + o->op_type != OP_NULL && + o->op_sibling && + o->op_sibling->op_type == OP_NULL) + { + OP *sib; + for (sib = o->op_sibling; + sib && sib->op_type == OP_NULL; + sib = sib->op_sibling) ; + + if (!sib) + return o; + } + if (o->op_type == OP_NEXTSTATE || o->op_type == OP_SETSTATE || o->op_type == OP_DBSTATE @@ -661,6 +790,15 @@ Perl_scalarvoid(pTHX_ OP *o) useless = OP_DESC(o); break; + case OP_NOT: + kid = cUNOPo->op_first; + if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && + kid->op_type != OP_TRANS) { + goto func_ops; + } + useless = "negative pattern binding (!~)"; + break; + case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: @@ -677,10 +815,16 @@ Perl_scalarvoid(pTHX_ OP *o) else { if (ckWARN(WARN_VOID)) { useless = "a constant"; + if (o->op_private & OPpCONST_ARYBASE) + useless = 0; + /* don't warn on optimised away booleans, eg + * use constant Foo, 5; Foo || print; */ + if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) + useless = 0; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ - if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) + else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code @@ -689,9 +833,10 @@ Perl_scalarvoid(pTHX_ OP *o) built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ - if (strnEQ(SvPVX(sv), "di", 2) || - strnEQ(SvPVX(sv), "ds", 2) || - strnEQ(SvPVX(sv), "ig", 2)) + const char * const maybe_macro = SvPVX_const(sv); + if (strnEQ(maybe_macro, "di", 2) || + strnEQ(maybe_macro, "ds", 2) || + strnEQ(maybe_macro, "ig", 2)) useless = 0; } } @@ -709,10 +854,22 @@ Perl_scalarvoid(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PREDEC]; break; + case OP_I_POSTINC: + o->op_type = OP_I_PREINC; /* pre-increment is faster */ + o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; + break; + + case OP_I_POSTDEC: + o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ + o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; + break; + case OP_OR: case OP_AND: case OP_DOR: case OP_COND_EXPR: + case OP_ENTERGIVEN: + case OP_ENTERWHEN: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; @@ -734,6 +891,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: + case OP_LEAVEGIVEN: + case OP_LEAVEWHEN: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; @@ -761,8 +920,8 @@ Perl_scalarvoid(pTHX_ OP *o) OP * Perl_listkids(pTHX_ OP *o) { - OP *kid; if (o && o->op_flags & OPf_KIDS) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) list(kid); } @@ -772,6 +931,7 @@ Perl_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ @@ -847,14 +1007,14 @@ Perl_list(pTHX_ OP *o) OP * Perl_scalarseq(pTHX_ OP *o) { - OP *kid; - + dVAR; if (o) { if (o->op_type == OP_LINESEQ || o->op_type == OP_SCOPE || o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -874,15 +1034,15 @@ Perl_scalarseq(pTHX_ OP *o) STATIC OP * S_modkids(pTHX_ OP *o, I32 type) { - OP *kid; if (o && o->op_flags & OPf_KIDS) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); } return o; } -/* Propagate lvalue ("modifiable") context to an op and it's children. +/* Propagate lvalue ("modifiable") context to an op and its children. * 'type' represents the context type, roughly based on the type of op that * would do the modifying, although local() is represented by OP_NULL. * It's responsible for detecting things that can't be modified, flag @@ -896,6 +1056,7 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { + dVAR; OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ int localize = -1; @@ -915,8 +1076,9 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: - if (!(o->op_private & (OPpCONST_ARYBASE))) + if (!(o->op_private & OPpCONST_ARYBASE)) goto nomod; + localize = 0; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); PL_eval_start = 0; @@ -931,13 +1093,17 @@ Perl_mod(pTHX_ OP *o, I32 type) Perl_croak(aTHX_ "That use of $[ is unsupported"); break; case OP_STUB: - if (o->op_flags & OPf_PARENS) + if (o->op_flags & OPf_PARENS || PL_madskills) break; goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ + /* The default is to set op_private to the number of children, + which for a UNOP such as RV2CV is always 1. And w're using + the bit for a flag in RV2CV, so we need it clear. */ + o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ @@ -979,10 +1145,11 @@ Perl_mod(pTHX_ OP *o, I32 type) NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_first = Nullop; + newop->op_first = NULL; newop->op_next = (OP*)newop; kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; + newop->op_private &= ~1; break; } @@ -1012,11 +1179,12 @@ Perl_mod(pTHX_ OP *o, I32 type) kid->op_next = okid; } else - okid->op_next = Nullop; + okid->op_next = NULL; okid->op_type = OP_RV2CV; okid->op_targ = 0; okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; okid->op_private |= OPpLVAL_INTRO; + okid->op_private &= ~1; break; } @@ -1235,7 +1403,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } STATIC bool -S_scalar_mod_type(pTHX_ OP *o, I32 type) +S_scalar_mod_type(const OP *o, I32 type) { switch (type) { case OP_SASSIGN: @@ -1282,12 +1450,12 @@ S_scalar_mod_type(pTHX_ OP *o, I32 type) } STATIC bool -S_is_handle_constructor(pTHX_ OP *o, I32 argnum) +S_is_handle_constructor(const OP *o, I32 numargs) { switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: - if (argnum == 2) + if (numargs == 2) return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: @@ -1296,9 +1464,9 @@ S_is_handle_constructor(pTHX_ OP *o, I32 argnum) case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: - if (argnum == 1) + if (numargs == 1) return TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ default: return FALSE; } @@ -1307,8 +1475,8 @@ S_is_handle_constructor(pTHX_ OP *o, I32 argnum) OP * Perl_refkids(pTHX_ OP *o, I32 type) { - OP *kid; if (o && o->op_flags & OPf_KIDS) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) ref(kid, type); } @@ -1316,8 +1484,9 @@ Perl_refkids(pTHX_ OP *o, I32 type) } OP * -Perl_ref(pTHX_ OP *o, I32 type) +Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) { + dVAR; OP *kid; if (!o || PL_error_count) @@ -1332,17 +1501,18 @@ Perl_ref(pTHX_ OP *o, I32 type) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; + o->op_private &= ~1; } break; case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) - ref(kid, type); + doref(kid, type, set_op_ref); break; case OP_RV2SV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ - ref(cUNOPo->op_first, o->op_type); + doref(cUNOPo->op_first, o->op_type, set_op_ref); /* FALL THROUGH */ case OP_PADSV: if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { @@ -1359,28 +1529,30 @@ Perl_ref(pTHX_ OP *o, I32 type) case OP_RV2AV: case OP_RV2HV: - o->op_flags |= OPf_REF; + if (set_op_ref) + o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ - ref(cUNOPo->op_first, o->op_type); + doref(cUNOPo->op_first, o->op_type, set_op_ref); break; case OP_PADAV: case OP_PADHV: - o->op_flags |= OPf_REF; + if (set_op_ref) + o->op_flags |= OPf_REF; break; case OP_SCALAR: case OP_NULL: if (!(o->op_flags & OPf_KIDS)) break; - ref(cBINOPo->op_first, type); + doref(cBINOPo->op_first, type, set_op_ref); break; case OP_AELEM: case OP_HELEM: - ref(cBINOPo->op_first, o->op_type); + doref(cBINOPo->op_first, o->op_type, set_op_ref); if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV @@ -1391,11 +1563,13 @@ Perl_ref(pTHX_ OP *o, I32 type) case OP_SCOPE: case OP_LEAVE: + set_op_ref = FALSE; + /* FALL THROUGH */ case OP_ENTER: case OP_LIST: if (!(o->op_flags & OPf_KIDS)) break; - ref(cLISTOPo->op_last, type); + doref(cLISTOPo->op_last, type, set_op_ref); break; default: break; @@ -1407,21 +1581,27 @@ Perl_ref(pTHX_ OP *o, I32 type) STATIC OP * S_dup_attrlist(pTHX_ OP *o) { - OP *rop = Nullop; + dVAR; + OP *rop; /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, * where the first kid is OP_PUSHMARK and the remaining ones * 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(cSVOPo->op_sv)); + rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); +#ifdef PERL_MAD + else if (o->op_type == OP_NULL) + rop = Nullop; +#endif else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); + rop = NULL; for (o = cLISTOPo->op_first; o; o=o->op_sibling) { if (o->op_type == OP_CONST) rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, - SvREFCNT_inc(cSVOPo->op_sv))); + SvREFCNT_inc_NN(cSVOPo->op_sv))); } } return rop; @@ -1430,35 +1610,30 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { + dVAR; SV *stashsv; /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ SAVEINT(PL_expect); - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" if (for_my) { - SV **svp; /* Don't force the C if we don't need it. */ - svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, - sizeof(ATTRSMODULE_PM)-1, 0); + SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) - ; /* already in %INC */ + /*EMPTY*/; /* already in %INC */ else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv); + newSVpvs(ATTRSMODULE), NULL); } else { Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv, + newSVpvs(ATTRSMODULE), + NULL, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, @@ -1472,6 +1647,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { + dVAR; OP *pack, *imop, *arg; SV *meth, *stashsv; @@ -1486,13 +1662,11 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ - pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); + pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); /* Build up the real arg-list. */ - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; arg = prepend_elem(OP_LIST, @@ -1503,10 +1677,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) dup_attrlist(attrs))); /* Fake up a method call to import */ - meth = newSVpvn("import", 6); - (void)SvUPGRADE(meth, SVt_PVIV); - (void)SvIOK_on(meth); - PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + meth = newSVpvs_share("import"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), @@ -1535,10 +1706,10 @@ to respect attribute syntax properly would be welcome. */ void -Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, - char *attrstr, STRLEN len) +Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, + const char *attrstr, STRLEN len) { - OP *attrs = Nullop; + OP *attrs = NULL; if (!len) { len = strlen(attrstr); @@ -1547,7 +1718,7 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, while (len) { for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; if (len) { - char *sstr = attrstr; + const char * const sstr = attrstr; for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, @@ -1556,8 +1727,8 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, } Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv, prepend_elem(OP_LIST, + newSVpvs(ATTRSMODULE), + NULL, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, @@ -1568,17 +1739,28 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { - OP *kid; + dVAR; I32 type; if (!o || PL_error_count) return o; type = o->op_type; + + if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { + (void)my_kid(cUNOPo->op_first, attrs, imopsp); + return o; + } + if (type == OP_LIST) { + OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); - } else if (type == OP_UNDEF) { + } else if (type == OP_UNDEF +#ifdef PERL_MAD + || type == OP_STUB +#endif + ) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || @@ -1587,9 +1769,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) yyerror(Perl_form(aTHX_ "Can't declare %s in %s", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); } else if (attrs) { - GV *gv = cGVOPx_gv(cUNOPo->op_first); + GV * const gv = cGVOPx_gv(cUNOPo->op_first); PL_in_my = FALSE; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : @@ -1613,7 +1795,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) HV *stash; PL_in_my = FALSE; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; /* check for C when deciding package */ stash = PAD_COMPNAME_TYPE(o->op_targ); @@ -1629,7 +1811,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { - OP *rops = Nullop; + dVAR; + OP *rops; int maybe_scalar = 0; /* [perl #17376]: this appears to be premature, and results in code such as @@ -1644,6 +1827,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) #endif if (attrs) SAVEFREEOP(attrs); + rops = NULL; o = my_kid(o, attrs, &rops); if (rops) { if (maybe_scalar && o->op_type == OP_PADSV) { @@ -1654,19 +1838,20 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } PL_in_my = FALSE; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; return o; } OP * Perl_my(pTHX_ OP *o) { - return my_attrs(o, Nullop); + return my_attrs(o, NULL); } OP * Perl_sawparens(pTHX_ OP *o) { + PERL_UNUSED_CONTEXT; if (o) o->op_flags |= OPf_PARENS; return o; @@ -1678,15 +1863,16 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) OP *o; bool ismatchop = 0; - if (ckWARN(WARN_MISC) && - (left->op_type == OP_RV2AV || + if ( (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || - left->op_type == OP_PADHV)) { - char *desc = PL_op_desc[(right->op_type == OP_SUBST || + left->op_type == OP_PADHV) + && ckWARN(WARN_MISC)) + { + const char * const desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) ? right->op_type : OP_MATCH]; - const char *sample = ((left->op_type == OP_RV2AV || + const char * const sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -1724,7 +1910,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) } else return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, Nullop)); + pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * @@ -1739,6 +1925,7 @@ Perl_invert(pTHX_ OP *o) OP * Perl_scope(pTHX_ OP *o) { + dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); @@ -1750,28 +1937,27 @@ Perl_scope(pTHX_ OP *o) o->op_type = OP_SCOPE; o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + 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 = kid->op_sibling; + if (kid && + (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) + op_null(kid); + } } else - o = newLISTOP(OP_SCOPE, 0, o, Nullop); + o = newLISTOP(OP_SCOPE, 0, o, NULL); } return o; } -void -Perl_save_hints(pTHX) -{ - SAVEI32(PL_hints); - SAVESPTR(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv)); - SAVEFREESV(GvHV(PL_hintgv)); -} - int Perl_block_start(pTHX_ int full) { - int retval = PL_savestack_ix; + dVAR; + const int retval = PL_savestack_ix; pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; @@ -1791,8 +1977,9 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - OP* retval = scalarseq(seq); + dVAR; + const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; + OP* const retval = scalarseq(seq); LEAVE_SCOPE(floor); PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); if (needblockscope) @@ -1804,12 +1991,13 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) STATIC OP * S_newDEFSVOP(pTHX) { - I32 offset = pad_findmy("$_"); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { + dVAR; + const I32 offset = pad_findmy("$_"); + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { - OP *o = newOP(OP_PADSV, 0); + OP * const o = newOP(OP_PADSV, 0); o->op_targ = offset; return o; } @@ -1818,6 +2006,7 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { + dVAR; if (PL_in_eval) { if (PL_eval_root) return; @@ -1848,7 +2037,7 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV *cv = get_cv("DB::postponed", FALSE); + CV * const cv = get_cv("DB::postponed", FALSE); if (cv) { dSP; PUSHMARK(SP); @@ -1863,17 +2052,18 @@ Perl_newPROG(pTHX_ OP *o) OP * Perl_localize(pTHX_ OP *o, I32 lex) { + dVAR; if (o->op_flags & OPf_PARENS) /* [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); #else - ; + /*EMPTY*/; #endif else { - if (ckWARN(WARN_PARENTHESIS) - && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') + if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',' + && ckWARN(WARN_PARENTHESIS)) { char *s = PL_bufptr; bool sigil = FALSE; @@ -1908,7 +2098,7 @@ Perl_localize(pTHX_ OP *o, I32 lex) else o = mod(o, OP_NULL); /* a bit kludgey */ PL_in_my = FALSE; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; return o; } @@ -1916,8 +2106,9 @@ OP * Perl_jmaybe(pTHX_ OP *o) { if (o->op_type == OP_LIST) { - OP *o2; - o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), + OP * const o2 + = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, + SVt_PV))); o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; @@ -1926,7 +2117,9 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { + dVAR; register OP *curop; + OP *newop; I32 type = o->op_type; SV *sv; @@ -1952,7 +2145,6 @@ Perl_fold_constants(pTHX_ register OP *o) /* XXX might want a ck_negate() for this */ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; break; - case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: case OP_UC: @@ -1990,13 +2182,19 @@ Perl_fold_constants(pTHX_ register OP *o) 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? */ - (void)SvREFCNT_inc(sv); + SvREFCNT_inc_simple_void(sv); SvTEMP_off(sv); } + +#ifndef PERL_MAD op_free(o); +#endif if (type == OP_RV2GV) - return newGVOP(OP_GV, 0, (GV*)sv); - return newSVOP(OP_CONST, 0, sv); + newop = newGVOP(OP_GV, 0, (GV*)sv); + else + newop = newSVOP(OP_CONST, 0, sv); + op_getmad(o,newop,'f'); + return newop; nope: return o; @@ -2005,8 +2203,9 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { + dVAR; register OP *curop; - I32 oldtmps_floor = PL_tmps_floor; + const I32 oldtmps_floor = PL_tmps_floor; list(o); if (PL_error_count) @@ -2027,8 +2226,12 @@ Perl_gen_constant_list(pTHX_ register OP *o) o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in peep() */ curop = ((UNOP*)o)->op_first; - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); + ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--)); +#ifdef PERL_MAD + op_getmad(curop,o,'O'); +#else op_free(curop); +#endif linklist(o); return list(o); } @@ -2036,8 +2239,9 @@ Perl_gen_constant_list(pTHX_ register OP *o) OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { + dVAR; if (!o || o->op_type != OP_LIST) - o = newLISTOP(OP_LIST, 0, o, Nullop); + o = newLISTOP(OP_LIST, 0, o, NULL); else o->op_flags &= ~OPf_WANT; @@ -2049,7 +2253,7 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) o->op_flags |= flags; o = CHECKOP(type, o); - if (o->op_type != type) + if (o->op_type != (unsigned)type) return o; return fold_constants(o); @@ -2066,7 +2270,7 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) if (!last) return first; - if (first->op_type != type + if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { return newLISTOP(type, 0, first, last); @@ -2091,16 +2295,32 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) if (!last) return (OP*)first; - if (first->op_type != type) + if (first->op_type != (unsigned)type) return prepend_elem(type, (OP*)first, (OP*)last); - if (last->op_type != type) + if (last->op_type != (unsigned)type) return append_elem(type, (OP*)first, (OP*)last); first->op_last->op_sibling = last->op_first; first->op_last = last->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); +#ifdef PERL_MAD + if (last->op_first && first->op_madprop) { + MADPROP *mp = last->op_first->op_madprop; + if (mp) { + while (mp->mad_next) + mp = mp->mad_next; + mp->mad_next = first->op_madprop; + } + else { + last->op_first->op_madprop = first->op_madprop; + } + } + first->op_madprop = last->op_madprop; + last->op_madprop = 0; +#endif + FreeOp(last); return (OP*)first; @@ -2115,7 +2335,7 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (!last) return first; - if (last->op_type == type) { + if (last->op_type == (unsigned)type) { if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; @@ -2139,6 +2359,246 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) /* Constructors */ +#ifdef PERL_MAD + +TOKEN * +Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) +{ + TOKEN *tk; + Newxz(tk, 1, TOKEN); + tk->tk_type = (OPCODE)optype; + tk->tk_type = 12345; + tk->tk_lval = lval; + tk->tk_mad = madprop; + return tk; +} + +void +Perl_token_free(pTHX_ TOKEN* tk) +{ + if (tk->tk_type != 12345) + return; + mad_free(tk->tk_mad); + Safefree(tk); +} + +void +Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) +{ + MADPROP* mp; + MADPROP* tm; + if (tk->tk_type != 12345) { + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Invalid TOKEN object ignored"); + return; + } + tm = tk->tk_mad; + if (!tm) + return; + + /* faked up qw list? */ + if (slot == '(' && + tm->mad_type == MAD_SV && + SvPVX((SV*)tm->mad_val)[0] == 'q') + slot = 'x'; + + if (o) { + mp = o->op_madprop; + if (mp) { + for (;;) { + /* pretend constant fold didn't happen? */ + if (mp->mad_key == 'f' && + (o->op_type == OP_CONST || + o->op_type == OP_GV) ) + { + token_getmad(tk,(OP*)mp->mad_val,slot); + return; + } + if (!mp->mad_next) + break; + mp = mp->mad_next; + } + mp->mad_next = tm; + mp = mp->mad_next; + } + else { + o->op_madprop = tm; + mp = o->op_madprop; + } + if (mp->mad_key == 'X') + mp->mad_key = slot; /* just change the first one */ + + tk->tk_mad = 0; + } + else + mad_free(tm); + Safefree(tk); +} + +void +Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) +{ + MADPROP* mp; + if (!from) + return; + if (o) { + mp = o->op_madprop; + if (mp) { + for (;;) { + /* pretend constant fold didn't happen? */ + if (mp->mad_key == 'f' && + (o->op_type == OP_CONST || + o->op_type == OP_GV) ) + { + op_getmad(from,(OP*)mp->mad_val,slot); + return; + } + if (!mp->mad_next) + break; + mp = mp->mad_next; + } + mp->mad_next = newMADPROP(slot,MAD_OP,from,0); + } + else { + o->op_madprop = newMADPROP(slot,MAD_OP,from,0); + } + } +} + +void +Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) +{ + MADPROP* mp; + if (!from) + return; + if (o) { + mp = o->op_madprop; + if (mp) { + for (;;) { + /* pretend constant fold didn't happen? */ + if (mp->mad_key == 'f' && + (o->op_type == OP_CONST || + o->op_type == OP_GV) ) + { + op_getmad(from,(OP*)mp->mad_val,slot); + return; + } + if (!mp->mad_next) + break; + mp = mp->mad_next; + } + mp->mad_next = newMADPROP(slot,MAD_OP,from,1); + } + else { + o->op_madprop = newMADPROP(slot,MAD_OP,from,1); + } + } + else { + PerlIO_printf(PerlIO_stderr(), + "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); + op_free(from); + } +} + +void +Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) +{ + MADPROP* tm; + if (!mp || !o) + return; + if (slot) + mp->mad_key = slot; + tm = o->op_madprop; + o->op_madprop = mp; + for (;;) { + if (!mp->mad_next) + break; + mp = mp->mad_next; + } + mp->mad_next = tm; +} + +void +Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) +{ + if (!o) + return; + addmad(tm, &(o->op_madprop), slot); +} + +void +Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) +{ + MADPROP* mp; + if (!tm || !root) + return; + if (slot) + tm->mad_key = slot; + mp = *root; + if (!mp) { + *root = tm; + return; + } + for (;;) { + if (!mp->mad_next) + break; + mp = mp->mad_next; + } + mp->mad_next = tm; +} + +MADPROP * +Perl_newMADsv(pTHX_ char key, SV* sv) +{ + return newMADPROP(key, MAD_SV, sv, 0); +} + +MADPROP * +Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) +{ + MADPROP *mp; + Newxz(mp, 1, MADPROP); + mp->mad_next = 0; + mp->mad_key = key; + mp->mad_vlen = vlen; + mp->mad_type = type; + mp->mad_val = val; +/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ + return mp; +} + +void +Perl_mad_free(pTHX_ MADPROP* mp) +{ +/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ + if (!mp) + return; + if (mp->mad_next) + mad_free(mp->mad_next); +/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen) + PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ + switch (mp->mad_type) { + case MAD_NULL: + break; + case MAD_PV: + Safefree((char*)mp->mad_val); + break; + case MAD_OP: + if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ + op_free((OP*)mp->mad_val); + break; + case MAD_SV: + sv_free((SV*)mp->mad_val); + break; + default: + PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); + break; + } + Safefree(mp); +} + +#endif + OP * Perl_newNULLLIST(pTHX) { @@ -2149,7 +2609,7 @@ OP * Perl_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) - o = newLISTOP(OP_LIST, 0, o, Nullop); + o = newLISTOP(OP_LIST, 0, o, NULL); op_null(o); return o; } @@ -2157,6 +2617,7 @@ Perl_force_list(pTHX_ OP *o) OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; LISTOP *listop; NewOp(1101, listop, 1, LISTOP); @@ -2176,8 +2637,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { - OP* pushop; - pushop = newOP(OP_PUSHMARK, 0); + OP* const pushop = newOP(OP_PUSHMARK, 0); pushop->op_sibling = first; listop->op_first = pushop; listop->op_flags |= OPf_KIDS; @@ -2191,6 +2651,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) OP * Perl_newOP(pTHX_ I32 type, I32 flags) { + dVAR; OP *o; NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; @@ -2209,6 +2670,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { + dVAR; UNOP *unop; if (!first) @@ -2220,7 +2682,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_type = (OPCODE)type; unop->op_ppaddr = PL_ppaddr[type]; unop->op_first = first; - unop->op_flags = flags | OPf_KIDS; + unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) @@ -2232,6 +2694,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; BINOP *binop; NewOp(1101, binop, 1, BINOP); @@ -2241,7 +2704,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) binop->op_type = (OPCODE)type; binop->op_ppaddr = PL_ppaddr[type]; binop->op_first = first; - binop->op_flags = flags | OPf_KIDS; + binop->op_flags = (U8)(flags | OPf_KIDS); if (!last) { last = first; binop->op_private = (U8)(1 | (flags >> 8)); @@ -2260,16 +2723,19 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) return fold_constants((OP *)binop); } -static int -uvcompare(const void *a, const void *b) +static int uvcompare(const void *a, const void *b) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__pure__; +static int uvcompare(const void *a, const void *b) { - if (*((UV *)a) < (*(UV *)b)) + if (*((const UV *)a) < (*(const UV *)b)) return -1; - if (*((UV *)a) > (*(UV *)b)) + if (*((const UV *)a) > (*(const UV *)b)) return 1; - if (*((UV *)a+1) < (*(UV *)b+1)) + if (*((const UV *)a+1) < (*(const UV *)b+1)) return -1; - if (*((UV *)a+1) > (*(UV *)b+1)) + if (*((const UV *)a+1) > (*(const UV *)b+1)) return 1; return 0; } @@ -2277,24 +2743,22 @@ uvcompare(const void *a, const void *b) OP * Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { - SV *tstr = ((SVOP*)expr)->op_sv; - SV *rstr = ((SVOP*)repl)->op_sv; + dVAR; + SV * const tstr = ((SVOP*)expr)->op_sv; + SV * const rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - U8 *t = (U8*)SvPV(tstr, tlen); - U8 *r = (U8*)SvPV(rstr, rlen); + const U8 *t = (U8*)SvPV_const(tstr, tlen); + const U8 *r = (U8*)SvPV_const(rstr, rlen); register I32 i; register I32 j; - I32 del; - I32 complement; - I32 squash; I32 grows = 0; register short *tbl; + const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; + const I32 squash = o->op_private & OPpTRANS_SQUASH; + I32 del = o->op_private & OPpTRANS_DELETE; PL_hints |= HINT_BLOCK_SCOPE; - complement = o->op_private & OPpTRANS_COMPLEMENT; - del = o->op_private & OPpTRANS_DELETE; - squash = o->op_private & OPpTRANS_SQUASH; if (SvUTF8(tstr)) o->op_private |= OPpTRANS_FROM_UTF; @@ -2303,10 +2767,10 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { - SV* listsv = newSVpvn("# comment\n",10); - SV* transv = 0; - U8* tend = t + tlen; - U8* rend = r + rlen; + SV* const listsv = newSVpvs("# comment\n"); + SV* transv = NULL; + const U8* tend = t + tlen; + const U8* rend = r + rlen; STRLEN ulen; UV tfirst = 1; UV tlast = 0; @@ -2320,19 +2784,19 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 bits; I32 havefinal = 0; U32 final = 0; - I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; - I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; + const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; U8* tsave = NULL; U8* rsave = NULL; if (!from_utf) { STRLEN len = tlen; - tsave = t = bytes_to_utf8(t, &len); + t = tsave = bytes_to_utf8(t, &len); tend = t + len; } if (!to_utf && rlen) { STRLEN len = rlen; - rsave = r = bytes_to_utf8(r, &len); + r = rsave = bytes_to_utf8(r, &len); rend = r + len; } @@ -2343,12 +2807,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) */ if (complement) { - U8 tmpbuf[UTF8_MAXLEN+1]; + U8 tmpbuf[UTF8_MAXBYTES+1]; UV *cp; UV nextmin = 0; - New(1109, cp, 2*tlen, UV); + Newx(cp, 2*tlen, UV); i = 0; - transv = newSVpvn("",0); + transv = newSVpvs(""); while (t < tend) { cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); t += ulen; @@ -2389,7 +2853,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); - t = (U8*)SvPVX(transv); + t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); tend = t + tlen; Safefree(cp); @@ -2489,8 +2953,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) Safefree(cPVOPo->op_pv); cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); SvREFCNT_dec(listsv); - if (transv) - SvREFCNT_dec(transv); + SvREFCNT_dec(transv); if (!del && havefinal && rlen) (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, @@ -2499,13 +2962,16 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (grows) o->op_private |= OPpTRANS_GROWS; - if (tsave) - Safefree(tsave); - if (rsave) - Safefree(rsave); + Safefree(tsave); + Safefree(rsave); +#ifdef PERL_MAD + op_getmad(expr,o,'e'); + op_getmad(repl,o,'r'); +#else op_free(expr); op_free(repl); +#endif return o; } @@ -2541,7 +3007,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) j = rlen - 1; else cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); - tbl[0x100] = rlen - j; + tbl[0x100] = (short)(rlen - j); for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; } @@ -2575,8 +3041,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } if (grows) o->op_private |= OPpTRANS_GROWS; +#ifdef PERL_MAD + op_getmad(expr,o,'e'); + op_getmad(repl,o,'r'); +#else op_free(expr); op_free(repl); +#endif return o; } @@ -2584,6 +3055,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { + dVAR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2599,60 +3071,124 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmflags = pmop->op_pmpermflags; #ifdef USE_ITHREADS - { - SV* repointer; - if(av_len((AV*) PL_regex_pad[0]) > -1) { - repointer = av_pop((AV*)PL_regex_pad[0]); - pmop->op_pmoffset = SvIV(repointer); - SvREPADTMP_off(repointer); - sv_setiv(repointer,0); - } else { - repointer = newSViv(0); - av_push(PL_regex_padav,SvREFCNT_inc(repointer)); - pmop->op_pmoffset = av_len(PL_regex_padav); - PL_regex_pad = AvARRAY(PL_regex_padav); - } + if (av_len((AV*) PL_regex_pad[0]) > -1) { + SV * const repointer = av_pop((AV*)PL_regex_pad[0]); + pmop->op_pmoffset = SvIV(repointer); + SvREPADTMP_off(repointer); + sv_setiv(repointer,0); + } else { + SV * const repointer = newSViv(0); + av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer)); + pmop->op_pmoffset = av_len(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); } #endif /* link into pm list */ if (type != OP_TRANS && PL_curstash) { - pmop->op_pmnext = HvPMROOT(PL_curstash); - HvPMROOT(PL_curstash) = pmop; + MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); + + if (!mg) { + mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); + } + pmop->op_pmnext = (PMOP*)mg->mg_obj; + mg->mg_obj = (SV*)pmop; PmopSTASH_set(pmop,PL_curstash); } return CHECKOP(type, pmop); } +/* Given some sort of match op o, and an expression expr containing a + * pattern, either compile expr into a regex and attach it to o (if it's + * constant), or convert expr into a runtime regcomp op sequence (if it's + * not) + * + * isreg indicates that the pattern is part of a regex construct, eg + * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or + * split "pattern", which aren't. In the former case, expr will be a list + * if the pattern contains more than one term (eg /a$b/) or if it contains + * a replacement, ie s/// or tr///. + */ + OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) +Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) { + dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; + OP* repl = NULL; + bool reglist; + + if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { + /* last element in list is the replacement; pop it */ + OP* kid; + repl = cLISTOPx(expr)->op_last; + kid = cLISTOPx(expr)->op_first; + while (kid->op_sibling != repl) + kid = kid->op_sibling; + kid->op_sibling = NULL; + cLISTOPx(expr)->op_last = kid; + } - if (o->op_type == OP_TRANS) + if (isreg && expr->op_type == OP_LIST && + cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) + { + /* convert single element list to element */ + OP* const oe = expr; + expr = cLISTOPx(oe)->op_first->op_sibling; + cLISTOPx(oe)->op_first->op_sibling = NULL; + cLISTOPx(oe)->op_last = NULL; + op_free(oe); + } + + if (o->op_type == OP_TRANS) { return pmtrans(o, expr, repl); + } + + reglist = isreg && expr->op_type == OP_LIST; + if (reglist) + op_null(expr); PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; if (expr->op_type == OP_CONST) { STRLEN plen; - SV *pat = ((SVOP*)expr)->op_sv; - char *p = SvPV(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { + SV * const pat = ((SVOP*)expr)->op_sv; + const char *p = SvPV_const(pat, plen); + if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { + U32 was_readonly = SvREADONLY(pat); + + if (was_readonly) { + if (SvFAKE(pat)) { + sv_force_normal_flags(pat, 0); + assert(!SvREADONLY(pat)); + was_readonly = 0; + } else { + SvREADONLY_off(pat); + } + } + sv_setpvn(pat, "\\s+", 3); - p = SvPV(pat, plen); + + SvFLAGS(pat) |= was_readonly; + + p = SvPV_const(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } if (DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; - PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); + /* FIXME - can we make this function take const char * args? */ + PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; +#ifdef PERL_MAD + op_getmad(expr,(OP*)pm,'e'); +#else op_free(expr); +#endif } else { if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) @@ -2664,11 +3200,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) rcop->op_type = OP_REGCOMP; rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; rcop->op_first = scalar(expr); - rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) - ? (OPf_SPECIAL | OPf_KIDS) - : OPf_KIDS); + rcop->op_flags |= OPf_KIDS + | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); rcop->op_private = 1; rcop->op_other = o; + if (reglist) + rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); + /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ PL_cv_has_eval = 1; @@ -2689,18 +3228,18 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (repl) { OP *curop; if (pm->op_pmflags & PMf_EVAL) { - curop = 0; + curop = NULL; if (CopLINE(PL_curcop) < (line_t)PL_multi_end) CopLINE_set(PL_curcop, (line_t)PL_multi_end); } else if (repl->op_type == OP_CONST) curop = repl; else { - OP *lastop = 0; + OP *lastop = NULL; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { - GV *gv = cGVOPx_gv(curop); + GV * const gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) break; @@ -2721,7 +3260,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) repl_has_vars = 1; } else if (curop->op_type == OP_PUSHRE) - ; /* Okay here, dangerous in newASSIGNOP */ + /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */ else break; } @@ -2765,6 +3304,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; SVOP *svop; NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; @@ -2782,6 +3322,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; PADOP *padop; NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; @@ -2803,18 +3344,20 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { + dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); - return newPADOP(type, flags, SvREFCNT_inc(gv)); + return newPADOP(type, flags, SvREFCNT_inc_simple(gv)); #else - return newSVOP(type, flags, SvREFCNT_inc(gv)); + return newSVOP(type, flags, SvREFCNT_inc_simple(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { + dVAR; PVOP *pvop; NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; @@ -2829,41 +3372,74 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) return CHECKOP(type, pvop); } +#ifdef PERL_MAD +OP* +#else void +#endif Perl_package(pTHX_ OP *o) { - char *name; + dVAR; + const char *name; STRLEN len; +#ifdef PERL_MAD + OP *pegop; +#endif save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV(cSVOPo->op_sv, len); + name = SvPV_const(cSVOPo->op_sv, len); PL_curstash = gv_stashpvn(name, len, TRUE); sv_setpvn(PL_curstname, name, len); - op_free(o); PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; + +#ifndef PERL_MAD + op_free(o); +#else + if (!PL_madskills) { + op_free(o); + return Nullop; + } + + pegop = newOP(OP_NULL,0); + op_getmad(o,pegop,'P'); + return pegop; +#endif } +#ifdef PERL_MAD +OP* +#else void +#endif Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { + dVAR; OP *pack; OP *imop; OP *veop; +#ifdef PERL_MAD + OP *pegop = newOP(OP_NULL,0); +#endif if (idop->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); - veop = Nullop; + if (PL_madskills) + op_getmad(idop,pegop,'U'); + + veop = NULL; - if (version != Nullop) { - SV *vesv = ((SVOP*)version)->op_sv; + if (version) { + SV * const vesv = ((SVOP*)version)->op_sv; - if (arg == Nullop && !SvNIOKp(vesv)) { + if (PL_madskills) + op_getmad(version,pegop,'V'); + if (!arg && !SvNIOKp(vesv)) { arg = version; } else { @@ -2877,10 +3453,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ - meth = newSVpvn("VERSION",7); - sv_upgrade(meth, SVt_PVIV); - (void)SvIOK_on(meth); - PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + meth = newSVpvs_share("VERSION"); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), @@ -2889,22 +3462,28 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) } /* Fake up an import/unimport */ - if (arg && arg->op_type == OP_STUB) + if (arg && arg->op_type == OP_STUB) { + if (PL_madskills) + op_getmad(arg,pegop,'S'); imop = arg; /* no import on explicit () */ + } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { - imop = Nullop; /* use 5.0; */ + imop = NULL; /* use 5.0; */ + if (!aver) + idop->op_private |= OPpCONST_NOVER; } else { SV *meth; + if (PL_madskills) + op_getmad(arg,pegop,'A'); + /* 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 ? newSVpvn("import",6) : newSVpvn("unimport", 8); - (void)SvUPGRADE(meth, SVt_PVIV); - (void)SvIOK_on(meth); - PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + meth = aver + ? newSVpvs_share("import") : newSVpvs_share("unimport"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), @@ -2913,14 +3492,14 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, - newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), - Nullop, - Nullop, + newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), + NULL, + NULL, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), - newSTATEOP(0, Nullch, veop)), - newSTATEOP(0, Nullch, imop) )); + newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), + newSTATEOP(0, NULL, veop)), + newSTATEOP(0, NULL, imop) )); /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one @@ -2943,6 +3522,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_copline = NOLINE; PL_expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ + +#ifdef PERL_MAD + if (!PL_madskills) { + /* FIXME - don't allocate pegop if !PL_madskills */ + op_free(pegop); + return Nullop; + } + return pegop; +#endif } /* @@ -2985,15 +3573,16 @@ Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { - OP *modname, *veop, *imop; + dVAR; + OP *veop, *imop; - modname = newSVOP(OP_CONST, 0, name); + OP * const modname = newSVOP(OP_CONST, 0, name); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else - veop = Nullop; + veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } @@ -3002,7 +3591,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) } else { SV *sv; - imop = Nullop; + imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); @@ -3010,9 +3599,9 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) } } { - line_t ocopline = PL_copline; - COP *ocurcop = PL_curcop; - int oexpect = PL_expect; + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); @@ -3023,14 +3612,19 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) } OP * -Perl_dofile(pTHX_ OP *term) +Perl_dofile(pTHX_ OP *term, I32 force_builtin) { + dVAR; OP *doop; - GV *gv; + GV *gv = NULL; - gv = gv_fetchpv("do", FALSE, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) - gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); + if (!force_builtin) { + gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV); + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { + GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE); + gv = gvp ? *gvp : NULL; + } + } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, @@ -3054,7 +3648,7 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) } STATIC I32 -S_list_assignment(pTHX_ register OP *o) +S_is_list_assignment(pTHX_ register const OP *o) { if (!o) return TRUE; @@ -3063,8 +3657,8 @@ S_list_assignment(pTHX_ register OP *o) o = cUNOPo->op_first; if (o->op_type == OP_COND_EXPR) { - I32 t = list_assignment(cLOGOPo->op_first->op_sibling); - I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); + const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -3095,6 +3689,7 @@ S_list_assignment(pTHX_ register OP *o) OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { + dVAR; OP *o; if (optype) { @@ -3109,18 +3704,20 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } - if (list_assignment(left)) { + if (is_list_assignment(left)) { OP *curop; PL_modcount = 0; - PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ + /* Grandfathering $[ assignment here. Bletch.*/ + /* Only simple assignments like C<< ($[) = 1 >> are allowed */ + PL_eval_start = (left->op_type == OP_CONST) ? right : 0; left = mod(left, OP_AASSIGN); if (PL_eval_start) PL_eval_start = 0; - else { - op_free(left); - op_free(right); - return Nullop; + else if (left->op_type == OP_CONST) { + /* FIXME for MAD */ + /* Result of assignment is always 1 (or we'd be dead already) */ + return newSVOP(OP_CONST, 0, newSViv(1)); } curop = list(force_list(left)); o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); @@ -3147,9 +3744,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); - if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; - SvCUR(gv) = PL_generation; + GvASSIGN_GENERATION_set(gv, PL_generation); } else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || @@ -3159,8 +3757,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) break; - PAD_COMPNAME_GEN(curop->op_targ) - = PL_generation; + PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } else if (curop->op_type == OP_RV2CV) @@ -3180,9 +3777,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) #else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif - if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; - SvCUR(gv) = PL_generation; + GvASSIGN_GENERATION_set(gv, PL_generation); + GvASSIGN_GENERATION_set(gv, PL_generation); } } else @@ -3198,7 +3797,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if ((tmpop = ((LISTOP*)right)->op_first) && tmpop->op_type == OP_PUSHRE) { - PMOP *pm = (PMOP*)tmpop; + PMOP * const pm = (PMOP*)tmpop; if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) @@ -3210,14 +3809,18 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; - cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ + cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - tmpop->op_sibling = Nullop; /* don't free split */ + tmpop->op_sibling = NULL; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ +#ifdef PERL_MAD + op_getmad(o,right,'R'); /* blow off assign */ +#else op_free(o); /* blow off assign */ +#endif right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; @@ -3249,8 +3852,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_eval_start) PL_eval_start = 0; else { + /* FIXME for MAD */ op_free(o); - return Nullop; + o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); + o->op_private |= OPpCONST_ARYBASE; } } return o; @@ -3259,7 +3864,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - U32 seq = intro_my(); + dVAR; + const U32 seq = intro_my(); register COP *cop; NewOp(1101, cop, 1, COP); @@ -3309,39 +3915,41 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopSTASH_set(cop, PL_curstash); if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef ) { - (void)SvIOK_on(*svp); - SvIVX(*svp) = PTR2IV(cop); + SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); + SvIV_set(*svp, PTR2IV(cop)); } } - o = prepend_elem(OP_LINESEQ, (OP*)cop, o); - CHECKOP(cop->op_type, cop); - return o; + return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { + dVAR; return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { + dVAR; LOGOP *logop; OP *o; OP *first = *firstp; - OP *other = *otherp; + OP * const other = *otherp; if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ - if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { + if (first->op_type == OP_NOT + && (first->op_flags & OPf_SPECIAL) + && (first->op_flags & OPf_KIDS)) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; @@ -3351,31 +3959,70 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first = *firstp = cUNOPo->op_first; if (o->op_next) first->op_next = o->op_next; - cUNOPo->op_first = Nullop; + cUNOPo->op_first = NULL; +#ifdef PERL_MAD + op_getmad(o,first,'O'); +#else op_free(o); +#endif } } if (first->op_type == OP_CONST) { if (first->op_private & OPpCONST_STRICT) no_bareword_allowed(first); - else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) + else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); - if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { + if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { + *firstp = NULL; + if (other->op_type == OP_CONST) + other->op_private |= OPpCONST_SHORTCIRCUIT; + if (PL_madskills) { + OP *newop = newUNOP(OP_NULL, 0, other); + op_getmad(first, newop, '1'); + newop->op_targ = type; /* set "was" field */ + return newop; + } op_free(first); - *firstp = Nullop; return other; } else { - op_free(other); - *otherp = Nullop; + /* 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 = o2->op_sibling)) ) + ) + o2 = other; + if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV + || o2->op_type == OP_PADHV) + && o2->op_private & OPpLVAL_INTRO + && ckWARN(WARN_DEPRECATED)) + { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + "Deprecated use of my() in false conditional"); + } + + *otherp = NULL; + if (first->op_type == OP_CONST) + first->op_private |= OPpCONST_SHORTCIRCUIT; + if (PL_madskills) { + first = newUNOP(OP_NULL, 0, first); + op_getmad(other, first, '2'); + first->op_targ = type; /* set "was" field */ + } + else + op_free(other); return first; } } - else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && - type != OP_DOR) /* [#24076] Don't warn for err FOO. */ + else if ((first->op_flags & OPf_KIDS) && type != OP_DOR + && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { - OP *k1 = ((UNOP*)first)->op_first; - OP *k2 = k1->op_sibling; + const OP * const k1 = ((UNOP*)first)->op_first; + const OP * const k2 = k1->op_sibling; OPCODE warnop = 0; switch (first->op_type) { @@ -3400,7 +4047,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) break; } if (warnop) { - line_t oldline = CopLINE(PL_curcop); + const line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", @@ -3422,7 +4069,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) logop->op_type = (OPCODE)type; logop->op_ppaddr = PL_ppaddr[type]; logop->op_first = first; - logop->op_flags = flags | OPf_KIDS; + logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_other = LINKLIST(other); logop->op_private = (U8)(1 | (flags >> 8)); @@ -3442,6 +4089,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { + dVAR; LOGOP *logop; OP *start; OP *o; @@ -3454,17 +4102,35 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) scalarboolean(first); if (first->op_type == OP_CONST) { if (first->op_private & OPpCONST_BARE && - first->op_private & OPpCONST_STRICT) { - no_bareword_allowed(first); - } + first->op_private & OPpCONST_STRICT) { + no_bareword_allowed(first); + } if (SvTRUE(((SVOP*)first)->op_sv)) { +#ifdef PERL_MAD + if (PL_madskills) { + trueop = newUNOP(OP_NULL, 0, trueop); + op_getmad(first,trueop,'C'); + op_getmad(falseop,trueop,'e'); + } + /* FIXME for MAD - should there be an ELSE here? */ +#else op_free(first); op_free(falseop); +#endif return trueop; } else { +#ifdef PERL_MAD + if (PL_madskills) { + falseop = newUNOP(OP_NULL, 0, falseop); + op_getmad(first,falseop,'C'); + op_getmad(trueop,falseop,'t'); + } + /* FIXME for MAD - should there be an ELSE here? */ +#else op_free(first); op_free(trueop); +#endif return falseop; } } @@ -3472,7 +4138,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) logop->op_type = OP_COND_EXPR; logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; logop->op_first = first; - logop->op_flags = flags | OPf_KIDS; + logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_private = (U8)(1 | (flags >> 8)); logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); @@ -3497,6 +4163,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { + dVAR; LOGOP *range; OP *flip; OP *flop; @@ -3543,11 +4210,14 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { + dVAR; OP* listop; OP* o; - int once = block && block->op_flags & OPf_SPECIAL && + const bool once = block && block->op_flags & OPf_SPECIAL && (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); + PERL_UNUSED_ARG(debuggable); + if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ @@ -3556,8 +4226,8 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { - OP *k1 = ((UNOP*)expr)->op_first; - OP *k2 = (k1) ? k1->op_sibling : NULL; + const OP * const k1 = ((UNOP*)expr)->op_first; + const OP * const k2 = k1 ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && k2->op_type == OP_READLINE @@ -3567,10 +4237,10 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) break; case OP_SASSIGN: - if (k1->op_type == OP_READDIR + 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_EACH)) expr = newUNOP(OP_DEFINED, 0, expr); break; } @@ -3600,42 +4270,48 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) } OP * -Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) +Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 +whileline, OP *expr, OP *block, OP *cont, I32 has_my) { + dVAR; OP *redo; - OP *next = 0; + OP *next = NULL; OP *listop; OP *o; U8 loopflags = 0; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB - || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { - expr = newUNOP(OP_DEFINED, 0, - newASSIGNOP(0, newDEFSVOP(), 0, expr) ); - } else if (expr && (expr->op_flags & OPf_KIDS)) { - OP *k1 = ((UNOP*)expr)->op_first; - OP *k2 = (k1) ? k1->op_sibling : NULL; - switch (expr->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)) - expr = newUNOP(OP_DEFINED, 0, expr); - break; + PERL_UNUSED_ARG(debuggable); - 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) - expr = newUNOP(OP_DEFINED, 0, expr); - break; + if (expr) { + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (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) ? k1->op_sibling : NULL; + switch (expr->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)) + expr = newUNOP(OP_DEFINED, 0, expr); + 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) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } } } if (!block) block = newOP(OP_NULL, 0); - else if (cont) { + else if (cont || has_my) { block = scope(block); } @@ -3643,7 +4319,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * next = LINKLIST(cont); } if (expr) { - OP *unstack = newOP(OP_UNSTACK, 0); + OP * const unstack = newOP(OP_UNSTACK, 0); if (!next) next = unstack; cont = append_elem(OP_LINESEQ, cont, unstack); @@ -3659,7 +4335,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); - return Nullop; /* listop already freed by new_logop */ + return NULL; /* listop already freed by new_logop */ } if (listop) ((LISTOP*)listop)->op_last->op_next = @@ -3693,45 +4369,60 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * } OP * -Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) +Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) { + dVAR; LOOP *loop; OP *wop; PADOFFSET padoff = 0; I32 iterflags = 0; I32 iterpflags = 0; + OP *madsv = 0; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ sv->op_type = OP_RV2GV; sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; + if (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 = Nullop; + if (PL_madskills) + madsv = sv; + else { + sv->op_targ = 0; + op_free(sv); + } + sv = NULL; } else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ padoff = sv->op_targ; - sv->op_targ = 0; - iterflags |= OPf_SPECIAL; - op_free(sv); - sv = Nullop; + if (PL_madskills) + madsv = sv; + else { + sv->op_targ = 0; + iterflags |= OPf_SPECIAL; + op_free(sv); + } + sv = NULL; } else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); + if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_")) + iterpflags |= OPpITER_DEF; } else { - I32 offset = pad_findmy("$_"); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { + const I32 offset = pad_findmy("$_"); + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } else { padoff = offset; } + iterpflags |= OPpITER_DEF; } if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); @@ -3745,14 +4436,14 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo * set the STACKED flag to indicate that these values are to be * treated as min/max values by 'pp_iterinit'. */ - UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; - LOGOP* range = (LOGOP*) flip->op_first; - OP* left = range->op_first; - OP* right = left->op_sibling; + 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 = left->op_sibling; LISTOP* listop; range->op_flags &= ~OPf_KIDS; - range->op_first = Nullop; + range->op_first = NULL; listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); listop->op_first->op_next = range->op_next; @@ -3760,7 +4451,11 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo right->op_next = (OP*)listop; listop->op_next = listop->op_first; +#ifdef PERL_MAD + op_getmad(expr,(OP*)listop,'O'); +#else op_free(expr); +#endif expr = (OP*)(listop); op_null(expr); iterflags |= OPf_STACKED; @@ -3769,7 +4464,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo expr = mod(force_list(expr), OP_GREPSTART); } - loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); @@ -3780,7 +4474,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo { LOOP *tmp; NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LOOP); + Copy(loop,tmp,1,LISTOP); FreeOp(loop); loop = tmp; } @@ -3788,7 +4482,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo Renew(loop, 1, LOOP); #endif loop->op_targ = padoff; - wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); + if (madsv) + op_getmad(madsv, (OP*)loop, 'v'); PL_copline = forline; return newSTATEOP(0, label, wop); } @@ -3796,8 +4492,8 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { + dVAR; OP *o; - STRLEN n_a; if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ @@ -3805,10 +4501,14 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, n_a) + ? SvPVx_nolen_const(((SVOP*)label)->op_sv) : "")); } +#ifdef PERL_MAD + op_getmad(label,o,'L'); +#else op_free(label); +#endif } else { /* Check whether it's going to be a goto &function */ @@ -3821,6 +4521,180 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) return o; } +/* if the condition is a literal array or hash + (or @{ ... } etc), make a reference to it. + */ +STATIC OP * +S_ref_array_or_hash(pTHX_ OP *cond) +{ + if (cond + && (cond->op_type == OP_RV2AV + || cond->op_type == OP_PADAV + || cond->op_type == OP_RV2HV + || cond->op_type == OP_PADHV)) + + return newUNOP(OP_REFGEN, + 0, mod(cond, OP_REFGEN)); + + else + return cond; +} + +/* These construct the optree fragments representing given() + and when() blocks. + + entergiven and enterwhen are LOGOPs; the op_other pointer + points up to the associated leave op. We need this so we + can put it in the context and make break/continue work. + (Also, of course, pp_enterwhen will jump straight to + op_other if the match fails.) + */ + +STATIC +OP * +S_newGIVWHENOP(pTHX_ OP *cond, OP *block, + I32 enter_opcode, I32 leave_opcode, + PADOFFSET entertarg) +{ + dVAR; + LOGOP *enterop; + OP *o; + + NewOp(1101, enterop, 1, LOGOP); + enterop->op_type = enter_opcode; + enterop->op_ppaddr = PL_ppaddr[enter_opcode]; + enterop->op_flags = (U8) OPf_KIDS; + enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); + enterop->op_private = 0; + + o = newUNOP(leave_opcode, 0, (OP *) enterop); + + if (cond) { + enterop->op_first = scalar(cond); + cond->op_sibling = block; + + o->op_next = LINKLIST(cond); + cond->op_next = (OP *) enterop; + } + else { + /* This is a default {} block */ + enterop->op_first = block; + enterop->op_flags |= OPf_SPECIAL; + + o->op_next = (OP *) enterop; + } + + CHECKOP(enter_opcode, enterop); /* Currently does nothing, since + entergiven and enterwhen both + use ck_null() */ + + enterop->op_next = LINKLIST(block); + block->op_next = enterop->op_other = o; + + return o; +} + +/* Does this look like a boolean operation? For these purposes + a boolean operation is: + - a subroutine call [*] + - a logical connective + - a comparison operator + - a filetest operator, with the exception of -s -M -A -C + - defined(), exists() or eof() + - /$re/ or $foo =~ /$re/ + + [*] possibly surprising + */ +STATIC +bool +S_looks_like_bool(pTHX_ OP *o) +{ + dVAR; + switch(o->op_type) { + case OP_OR: + return looks_like_bool(cLOGOPo->op_first); + + case OP_AND: + return ( + looks_like_bool(cLOGOPo->op_first) + && looks_like_bool(cLOGOPo->op_first->op_sibling)); + + case OP_ENTERSUB: + + case OP_NOT: case OP_XOR: + /* Note that OP_DOR is not here */ + + 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_SEQ: case OP_SNE: case OP_SLT: + case OP_SGT: case OP_SLE: case OP_SGE: + + 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_DEFINED: case OP_EXISTS: + case OP_MATCH: case OP_EOF: + + return TRUE; + + 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; + + /* FALL THROUGH */ + default: + return FALSE; + } +} + +OP * +Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) +{ + dVAR; + assert( cond ); + return newGIVWHENOP( + ref_array_or_hash(cond), + block, + OP_ENTERGIVEN, OP_LEAVEGIVEN, + defsv_off); +} + +/* If cond is null, this is a default {} block */ +OP * +Perl_newWHENOP(pTHX_ OP *cond, OP *block) +{ + bool cond_llb = (!cond || looks_like_bool(cond)); + OP *cond_op; + + if (cond_llb) + cond_op = cond; + else { + cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, + newDEFSVOP(), + scalar(ref_array_or_hash(cond))); + } + + return newGIVWHENOP( + cond_op, + append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)), + OP_ENTERWHEN, OP_LEAVEWHEN, 0); +} + /* =for apidoc cv_undef @@ -3835,27 +4709,29 @@ children can still follow the full lexical scope chain. void Perl_cv_undef(pTHX_ CV *cv) { + dVAR; #ifdef USE_ITHREADS - if (CvFILE(cv) && !CvXSUB(cv)) { + if (CvFILE(cv) && !CvISXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); } CvFILE(cv) = 0; #endif - if (!CvXSUB(cv) && CvROOT(cv)) { - if (CvDEPTH(cv)) + if (!CvISXSUB(cv) && CvROOT(cv)) { + if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); ENTER; PAD_SAVE_SETNULLPAD(); op_free(CvROOT(cv)); - CvROOT(cv) = Nullop; + CvROOT(cv) = NULL; + CvSTART(cv) = NULL; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvGV(cv) = Nullgv; + CvGV(cv) = NULL; pad_undef(cv); @@ -3863,38 +4739,40 @@ Perl_cv_undef(pTHX_ CV *cv) if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { if (!CvWEAKOUTSIDE(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = Nullcv; + CvOUTSIDE(cv) = NULL; } if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - if (CvXSUB(cv)) { - CvXSUB(cv) = 0; + if (CvISXSUB(cv) && CvXSUB(cv)) { + CvXSUB(cv) = NULL; } /* delete all flags except WEAKOUTSIDE */ CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void -Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) +Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) { - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { - SV* msg = sv_newmortal(); - SV* name = Nullsv; + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { + SV* const msg = sv_newmortal(); + SV* name = NULL; if (gv) - gv_efullname3(name = sv_newmortal(), gv, Nullch); + gv_efullname3(name = sv_newmortal(), gv, NULL); sv_setpv(msg, "Prototype mismatch:"); if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); - sv_catpv(msg, " vs "); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); + else + sv_catpvs(msg, ": none"); + sv_catpvs(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else - sv_catpv(msg, "none"); + sv_catpvs(msg, "none"); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); } } @@ -3918,9 +4796,12 @@ L. SV * Perl_cv_const_sv(pTHX_ CV *cv) { - if (!cv || !CvCONST(cv)) - return Nullsv; - return (SV*)CvXSUBANY(cv).any_ptr; + PERL_UNUSED_CONTEXT; + if (!cv) + return NULL; + if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) + return NULL; + return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. @@ -3944,18 +4825,19 @@ Perl_cv_const_sv(pTHX_ CV *cv) */ SV * -Perl_op_const_sv(pTHX_ OP *o, CV *cv) +Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { - SV *sv = Nullsv; + dVAR; + SV *sv = NULL; if (!o) - return Nullsv; + return NULL; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { - OPCODE type = o->op_type; + const OPCODE type = o->op_type; if (sv && o->op_next == o) return sv; @@ -3968,13 +4850,13 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) if (type == OP_LEAVESUB || type == OP_RETURN) break; if (sv) - return Nullsv; + return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) - return Nullsv; + return NULL; } else if (cv && type == OP_PADSV) { if (CvCONST(cv)) { /* newly cloned anon */ @@ -3982,7 +4864,7 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) /* the candidate should have 1 ref from this pad and 1 ref * from the parent */ if (!sv || SvREFCNT(sv) != 2) - return Nullsv; + return NULL; sv = newSVsv(sv); SvREADONLY_on(sv); return sv; @@ -3993,15 +4875,26 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) } } else { - return Nullsv; + return NULL; } } return sv; } +#ifdef PERL_MAD +OP * +#else void +#endif Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { +#if 0 + /* This would be the return value, but the return cannot be reached. */ + OP* pegop = newOP(OP_NULL, 0); +#endif + + PERL_UNUSED_ARG(floor); + if (o) SAVEFREEOP(o); if (proto) @@ -4011,46 +4904,68 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (block) SAVEFREEOP(block); Perl_croak(aTHX_ "\"my sub\" not yet implemented"); +#ifdef PERL_MAD + NORETURN_FUNCTION_END; +#endif } CV * Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) { - return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block); + return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block); } CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - STRLEN n_a; - char *name; - char *aname; + dVAR; + const char *aname; GV *gv; - char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; - register CV *cv=0; + const char *ps; + STRLEN ps_len; + register CV *cv = NULL; SV *const_sv; + /* If the subroutine has no body, no attributes, and no builtin attributes + then it's just a sub declaration, and we may be able to get away with + storing with a placeholder scalar in the symbol table, rather than a + full GV and CV. If anything is present then it will take a full CV to + store it. */ + const I32 gv_fetch_flags + = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) + || PL_madskills) + ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; + const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL; + + if (proto) { + assert(proto->op_type == OP_CONST); + ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); + } + else + ps = NULL; - name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { - SV *sv = sv_newmortal(); + 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)); - aname = SvPVX(sv); + aname = SvPVX_const(sv); } else - aname = Nullch; - gv = gv_fetchpv(name ? name : (aname ? aname : - (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + aname = NULL; - if (o) - SAVEFREEOP(o); - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); + gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV) + : gv_fetchpv(aname ? aname + : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), + gv_fetch_flags, SVt_PVCV); + + if (!PL_madskills) { + if (o) + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); + } if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ @@ -4063,7 +4978,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto((CV*)gv, NULL, ps); } if (ps) - sv_setpv((SV*)gv, ps); + sv_setpvn((SV*)gv, ps, ps_len); else sv_setiv((SV*)gv, -1); SvREFCNT_dec(PL_compcv); @@ -4072,7 +4987,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) goto done; } - cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); + cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); #ifdef GV_UNIQUE_CHECK if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { @@ -4080,13 +4995,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } #endif - if (!block || !ps || *ps || attrs) - const_sv = Nullsv; + if (!block || !ps || *ps || attrs + || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) +#ifdef PERL_MAD + || block->op_type == OP_NULL +#endif + ) + const_sv = NULL; else - const_sv = op_const_sv(block, Nullcv); + const_sv = op_const_sv(block, NULL); if (cv) { - bool exists = CvROOT(cv) || CvXSUB(cv); + const bool exists = CvROOT(cv) || CvXSUB(cv); #ifdef GV_UNIQUE_CHECK if (exists && GvUNIQUE(gv)) { @@ -4102,7 +5022,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - if (!block && !attrs) { + if ((!block +#ifdef PERL_MAD + || block->op_type == OP_NULL +#endif + )&& !attrs) { if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); @@ -4111,15 +5035,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } - /* ahem, death to those who redefine active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); - if (block) { + if (block +#ifdef PERL_MAD + && block->op_type != OP_NULL +#endif + ) { if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { - line_t oldline = CopLINE(PL_curcop); + const line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), @@ -4127,28 +5052,37 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) : "Subroutine %s redefined", name); CopLINE_set(PL_curcop, oldline); } - SvREFCNT_dec(cv); - cv = Nullcv; +#ifdef PERL_MAD + if (!PL_minus_c) /* keep old one around for madskills */ +#endif + { + /* (PL_madskills unset in used file.) */ + SvREFCNT_dec(cv); + } + cv = NULL; } } } if (const_sv) { - SvREFCNT_inc(const_sv); + SvREFCNT_inc_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); - sv_setpv((SV*)cv, ""); /* prototype is "" */ + sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); + CvISXSUB_on(cv); } else { - GvCV(gv) = Nullcv; + GvCV(gv) = NULL; cv = newCONSTSUB(NULL, name, const_sv); } + PL_sub_generation++; + if (PL_madskills) + goto install_block; op_free(block); SvREFCNT_dec(PL_compcv); PL_compcv = NULL; - PL_sub_generation++; goto done; } if (attrs) { @@ -4158,7 +5092,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* Need to do a C * before we clobber PL_compcv. */ - if (cv && !block) { + if (cv && (!block +#ifdef PERL_MAD + || block->op_type == OP_NULL +#endif + )) { rcv = (SV*)cv; /* Might have had built-in attributes applied -- propagate them. */ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); @@ -4180,7 +5118,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) apply_attrs(stash, rcv, attrs, FALSE); } if (cv) { /* must reuse cv if autoloaded */ - if (!block) { + if ( +#ifdef PERL_MAD + ( +#endif + !block +#ifdef PERL_MAD + || block->op_type == OP_NULL) && !PL_madskills +#endif + ) { /* got here with just attrs -- work done, so bug out */ SAVEFREESV(PL_compcv); goto done; @@ -4207,6 +5153,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = PL_compcv; if (name) { GvCV(gv) = cv; + if (PL_madskills) { + if (strEQ(name, "import")) { + PL_formfeed = (SV*)cv; + Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); + } + } GvCVGEN(gv) = 0; PL_sub_generation++; } @@ -4216,16 +5168,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH(cv) = PL_curstash; if (ps) - sv_setpv((SV*)cv, ps); + sv_setpvn((SV*)cv, ps, ps_len); if (PL_error_count) { op_free(block); - block = Nullop; + block = NULL; if (name) { - char *s = strrchr(name, ':'); + const char *s = strrchr(name, ':'); s = s ? s+1 : name; if (strEQ(s, "BEGIN")) { - char *not_safe = + const char not_safe[] = "BEGIN not safe after errors--compilation aborted"; if (PL_in_eval & EVAL_KEEPERR) Perl_croak(aTHX_ not_safe); @@ -4237,6 +5189,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } } + install_block: if (!block) goto done; @@ -4247,8 +5200,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { + OP* newblock = newSTATEOP(0, NULL, 0); +#ifdef PERL_MAD + op_getmad(block,newblock,'B'); +#else op_free(block); - block = newSTATEOP(0, Nullch, 0); +#endif + block = newblock; } CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } @@ -4269,30 +5227,31 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (name || aname) { - char *s; - char *tname = (name ? name : aname); + const char *s; + const char * const tname = (name ? name : aname); if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(0,0); - SV *tmpstr = sv_newmortal(); - GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); - CV *pcv; + SV * const sv = newSV(0); + SV * const tmpstr = sv_newmortal(); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); HV *hv; Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, Nullch); - hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + gv_efullname3(tmpstr, gv, NULL); + hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); - if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) - && (pcv = GvCV(db_postponed))) - { - dSP; - PUSHMARK(SP); - XPUSHs(tmpstr); - PUTBACK; - call_sv((SV*)pcv, G_DISCARD); + if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv((SV*)pcv, G_DISCARD); + } } } @@ -4305,7 +5264,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) goto done; if (strEQ(s, "BEGIN") && !PL_error_count) { - I32 oldscope = PL_scopestack_ix; + const I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); @@ -4367,8 +5326,9 @@ eligible for inlining at compile-time. */ CV * -Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) +Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { + dVAR; CV* cv; ENTER; @@ -4389,11 +5349,12 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - sv_setpv((SV*)cv, ""); /* prototype is "" */ + sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ +#ifdef USE_ITHREADS if (stash) CopSTASH_free(PL_curcop); - +#endif LEAVE; return cv; @@ -4408,9 +5369,10 @@ Used by C to hook up XSUBs as Perl subs. */ CV * -Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) +Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) { - GV *gv = gv_fetchpv(name ? name : + dVAR; + GV * const gv = gv_fetchpv(name ? name : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), GV_ADDMULTI, SVt_PVCV); register CV *cv; @@ -4418,34 +5380,43 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (!subaddr) Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); - if ((cv = (name ? GvCV(gv) : Nullcv))) { + if ((cv = (name ? GvCV(gv) : NULL))) { if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); - cv = 0; + cv = NULL; } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ - if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { - line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - CvCONST(cv) ? "Constant subroutine %s redefined" - : "Subroutine %s redefined" - ,name); - CopLINE_set(PL_curcop, oldline); + /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ + if (ckWARN(WARN_REDEFINE)) { + GV * const gvcv = CvGV(cv); + if (gvcv) { + HV * const stash = GvSTASH(gvcv); + if (stash) { + const char *redefined_name = HvNAME_get(stash); + if ( strEQ(redefined_name,"autouse") ) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_copline != NOLINE) + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); + CopLINE_set(PL_curcop, oldline); + } + } + } } SvREFCNT_dec(cv); - cv = 0; + cv = NULL; } } if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)NEWSV(1105,0); + cv = (CV*)newSV(0); sv_upgrade((SV *)cv, SVt_PVCV); if (name) { GvCV(gv) = cv; @@ -4455,12 +5426,13 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) } CvGV(cv) = gv; (void)gv_fetchfile(filename); - CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be + CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be an external constant string */ + CvISXSUB_on(cv); CvXSUB(cv) = subaddr; if (name) { - char *s = strrchr(name,':'); + const char *s = strrchr(name,':'); if (s) s++; else @@ -4507,19 +5479,23 @@ done: return cv; } +#ifdef PERL_MAD +OP * +#else void +#endif Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { + dVAR; register CV *cv; - char *name; - GV *gv; - STRLEN n_a; +#ifdef PERL_MAD + OP* pegop = newOP(OP_NULL, 0); +#endif + + GV * const gv = o + ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) + : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); - if (o) - name = SvPVx(cSVOPo->op_sv, n_a); - else - name = "STDOUT"; - gv = gv_fetchpv(name,TRUE, SVt_PVFM); #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); @@ -4528,10 +5504,12 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { - line_t oldline = CopLINE(PL_curcop); + const line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + o ? "Format %"SVf" redefined" + : "Format STDOUT redefined" ,cSVOPo->op_sv); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -4549,9 +5527,17 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); +#ifdef PERL_MAD + op_getmad(o,pegop,'n'); + op_getmad_weak(block, pegop, 'b'); +#else op_free(o); +#endif PL_copline = NOLINE; LEAVE_SCOPE(floor); +#ifdef PERL_MAD + return pegop; +#endif } OP * @@ -4571,7 +5557,7 @@ Perl_newANONHASH(pTHX_ OP *o) OP * Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) { - return newANONATTRSUB(floor, proto, Nullop, block); + return newANONATTRSUB(floor, proto, NULL, block); } OP * @@ -4585,6 +5571,7 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) OP * Perl_oopsAV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: o->op_type = OP_PADAV; @@ -4608,6 +5595,7 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4633,6 +5621,7 @@ Perl_oopsHV(pTHX_ OP *o) OP * Perl_newAVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; @@ -4657,6 +5646,7 @@ Perl_newGVREF(pTHX_ I32 type, OP *o) OP * Perl_newHVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADHV; o->op_ppaddr = PL_ppaddr[OP_PADHV]; @@ -4671,14 +5661,6 @@ Perl_newHVREF(pTHX_ OP *o) } OP * -Perl_oopsCV(pTHX_ OP *o) -{ - Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); - /* STUB */ - return o; -} - -OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) { return newUNOP(OP_RV2CV, flags, scalar(o)); @@ -4687,6 +5669,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) OP * Perl_newSVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADSV; o->op_ppaddr = PL_ppaddr[OP_PADSV]; @@ -4699,19 +5682,22 @@ Perl_newSVREF(pTHX_ OP *o) return newUNOP(OP_RV2SV, 0, scalar(o)); } -/* Check routines. */ +/* Check routines. See the comments at the top of this file for details + * on when these are called */ OP * Perl_ck_anoncode(pTHX_ OP *o) { cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); - cSVOPo->op_sv = Nullsv; + if (!PL_madskills) + cSVOPo->op_sv = Nullsv; return o; } OP * Perl_ck_bitop(pTHX_ OP *o) { + dVAR; #define OP_IS_NUMCOMPARE(op) \ ((op) == OP_LT || (op) == OP_I_LT || \ (op) == OP_GT || (op) == OP_I_GT || \ @@ -4726,8 +5712,8 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_AND || o->op_type == OP_BIT_XOR)) { - OP * left = cBINOPo->op_first; - OP * right = left->op_sibling; + const OP * const left = cBINOPo->op_first; + const OP * const right = left->op_sibling; if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -4745,7 +5731,8 @@ Perl_ck_bitop(pTHX_ OP *o) OP * Perl_ck_concat(pTHX_ OP *o) { - OP *kid = cUNOPo->op_first; + const OP * const kid = cUNOPo->op_first; + PERL_UNUSED_CONTEXT; if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && !(kUNOP->op_first->op_flags & OPf_MOD)) o->op_flags |= OPf_STACKED; @@ -4755,10 +5742,11 @@ Perl_ck_concat(pTHX_ OP *o) OP * Perl_ck_spair(pTHX_ OP *o) { + dVAR; if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; - OPCODE type = o->op_type; + const OPCODE type = o->op_type; o = modkids(ck_fun(o), type); kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; @@ -4770,7 +5758,11 @@ Perl_ck_spair(pTHX_ OP *o) return o; } +#ifdef PERL_MAD + op_getmad(kUNOP->op_first,newop,'K'); +#else op_free(kUNOP->op_first); +#endif kUNOP->op_first = newop; } o->op_ppaddr = PL_ppaddr[++o->op_type]; @@ -4783,7 +5775,7 @@ Perl_ck_delete(pTHX_ OP *o) o = ck_fun(o); o->op_private = 0; if (o->op_flags & OPf_KIDS) { - OP *kid = cUNOPo->op_first; + OP * const kid = cUNOPo->op_first; switch (kid->op_type) { case OP_ASLICE: o->op_flags |= OPf_SPECIAL; @@ -4817,12 +5809,19 @@ Perl_ck_die(pTHX_ OP *o) OP * Perl_ck_eof(pTHX_ OP *o) { - I32 type = o->op_type; + dVAR; + const I32 type = o->op_type; if (o->op_flags & OPf_KIDS) { if (cLISTOPo->op_first->op_type == OP_STUB) { + OP* newop + = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else op_free(o); - o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); +#endif + o = newop; } return ck_fun(o); } @@ -4832,9 +5831,10 @@ Perl_ck_eof(pTHX_ OP *o) OP * Perl_ck_eval(pTHX_ OP *o) { + dVAR; PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOPo->op_first; + SVOP * const kid = (SVOP*)cUNOPo->op_first; if (!kid) { o->op_flags &= ~OPf_KIDS; @@ -4842,9 +5842,14 @@ Perl_ck_eval(pTHX_ OP *o) } else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; +#ifdef PERL_MAD + OP* oldo = o; +#endif cUNOPo->op_first = 0; +#ifndef PERL_MAD op_free(o); +#endif NewOp(1101, enter, 1, LOGOP); enter->op_type = OP_ENTERTRY; @@ -4858,6 +5863,7 @@ Perl_ck_eval(pTHX_ OP *o) o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; enter->op_other = o; + op_getmad(oldo,o,'O'); return o; } else { @@ -4866,10 +5872,21 @@ Perl_ck_eval(pTHX_ OP *o) } } else { +#ifdef PERL_MAD + OP* oldo = o; +#else op_free(o); +#endif o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); + op_getmad(oldo,o,'O'); } o->op_targ = (PADOFFSET)PL_hints; + if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { + /* Store a copy of %^H that pp_entereval can pick up */ + OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv))); + cUNOPo->op_first->op_sibling = hhop; + o->op_private |= OPpEVAL_HAS_HH; + } return o; } @@ -4877,9 +5894,9 @@ OP * Perl_ck_exit(pTHX_ OP *o) { #ifdef VMS - HV *table = GvHV(PL_hintgv); + HV * const table = GvHV(PL_hintgv); if (table) { - SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE); if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } @@ -4891,8 +5908,8 @@ Perl_ck_exit(pTHX_ OP *o) OP * Perl_ck_exec(pTHX_ OP *o) { - OP *kid; if (o->op_flags & OPf_STACKED) { + OP *kid; o = ck_fun(o); kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) @@ -4906,9 +5923,10 @@ Perl_ck_exec(pTHX_ OP *o) OP * Perl_ck_exists(pTHX_ OP *o) { + dVAR; o = ck_fun(o); if (o->op_flags & OPf_KIDS) { - OP *kid = cUNOPo->op_first; + 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_error_count) @@ -4926,35 +5944,26 @@ Perl_ck_exists(pTHX_ OP *o) return o; } -#if 0 -OP * -Perl_ck_gvconst(pTHX_ register OP *o) -{ - o = fold_constants(o); - if (o->op_type == OP_CONST) - o->op_type = OP_GV; - return o; -} -#endif - OP * Perl_ck_rvconst(pTHX_ register OP *o) { - SVOP *kid = (SVOP*)cUNOPo->op_first; + dVAR; + SVOP * const kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); + if (o->op_type == OP_RV2CV) + o->op_private &= ~1; + if (kid->op_type == OP_CONST) { - char *name; int iscv; GV *gv; - SV *kidsv = kid->op_sv; - STRLEN n_a; + SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { - SV *rsv = SvRV(kidsv); - int svtype = SvTYPE(rsv); - char *badtype = Nullch; + SV * const rsv = SvRV(kidsv); + const int svtype = SvTYPE(rsv); + const char *badtype = NULL; switch (o->op_type) { case OP_RV2SV: @@ -4978,9 +5987,19 @@ Perl_ck_rvconst(pTHX_ register OP *o) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } - name = SvPV(kidsv, n_a); - if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { - char *badthing = Nullch; + else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) && + (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) { + /* If this is an access to a stash, disable "strict refs", because + * stashes aren't auto-vivified at compile-time (unless we store + * symbols in them), and we don't want to produce a run-time + * stricture error when auto-vivifying the stash. */ + const char *s = SvPV_nolen(kidsv); + const STRLEN l = SvCUR(kidsv); + if (l > 1 && s[l-1] == ':' && s[l-2] == ':') + o->op_private &= ~HINT_STRICT_REFS; + } + 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"; @@ -4991,11 +6010,14 @@ Perl_ck_rvconst(pTHX_ register OP *o) case OP_RV2HV: badthing = "a HASH"; break; + default: + badthing = NULL; + break; } if (badthing) Perl_croak(aTHX_ - "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", - name, badthing); + "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + kidsv, badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -5007,7 +6029,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) */ iscv = (o->op_type == OP_RV2CV) * 2; do { - gv = gv_fetchpv(name, + gv = gv_fetchsv(kidsv, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -5027,9 +6049,9 @@ Perl_ck_rvconst(pTHX_ register OP *o) kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); - PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv)); + PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv)); #else - kid->op_sv = SvREFCNT_inc(gv); + kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; @@ -5041,20 +6063,25 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - I32 type = o->op_type; + dVAR; + const I32 type = o->op_type; if (o->op_flags & OPf_REF) { - /* nothing */ + /*EMPTY*/; } else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { - SVOP *kid = (SVOP*)cUNOPo->op_first; + SVOP * const kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - STRLEN n_a; - OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); + OP * const newop = newGVOP(type, OPf_REF, + gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else op_free(o); +#endif o = newop; + return o; } else { if ((PL_hints & HINT_FILETEST_ACCESS) && @@ -5066,11 +6093,16 @@ Perl_ck_ftst(pTHX_ OP *o) o->op_private |= OPpFT_STACKED; } else { +#ifdef PERL_MAD + OP* oldo = o; +#else op_free(o); +#endif if (type == OP_FTTTY) o = newGVOP(type, OPf_REF, PL_stdingv); else o = newUNOP(type, 0, newDEFSVOP()); + op_getmad(oldo,o,'O'); } return o; } @@ -5078,11 +6110,8 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - register OP *kid; - OP **tokid; - OP *sibl; - I32 numargs = 0; - int type = o->op_type; + dVAR; + const int type = o->op_type; register I32 oa = PL_opargs[type] >> OASHIFT; if (o->op_flags & OPf_STACKED) { @@ -5093,9 +6122,11 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - STRLEN n_a; - tokid = &cLISTOPo->op_first; - kid = cLISTOPo->op_first; + OP **tokid = &cLISTOPo->op_first; + register OP *kid = cLISTOPo->op_first; + OP *sibl; + I32 numargs = 0; + if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { @@ -5108,6 +6139,12 @@ Perl_ck_fun(pTHX_ OP *o) while (oa && kid) { numargs++; sibl = kid->op_sibling; +#ifdef PERL_MAD + if (!sibl && kid->op_type == OP_STUB) { + numargs--; + break; + } +#endif switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ @@ -5136,14 +6173,17 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); - OP *newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVAV) )); + OP * const newop = newAVREF(newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Array @%s missing the @ in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); +#ifdef PERL_MAD + op_getmad(kid,newop,'K'); +#else op_free(kid); +#endif kid = newop; kid->op_sibling = sibl; *tokid = kid; @@ -5156,14 +6196,17 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); - OP *newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVHV) )); + OP * const newop = newHVREF(newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Hash %%%s missing the %% in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); +#ifdef PERL_MAD + op_getmad(kid,newop,'K'); +#else op_free(kid); +#endif kid = newop; kid->op_sibling = sibl; *tokid = kid; @@ -5174,7 +6217,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_CVREF: { - OP *newop = newUNOP(OP_NULL, 0, kid); + OP * const newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; linklist(kid); newop->op_next = newop; @@ -5188,13 +6231,16 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, - SVt_PVIO) ); + OP * const newop = newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) cLISTOPo->op_last = newop; +#ifdef PERL_MAD + op_getmad(kid,newop,'K'); +#else op_free(kid); +#endif kid = newop; } else if (kid->op_type == OP_READLINE) { @@ -5208,7 +6254,7 @@ Perl_ck_fun(pTHX_ OP *o) /* is this op a FH constructor? */ if (is_handle_constructor(o,numargs)) { - char *name = Nullch; + const char *name = NULL; STRLEN len = 0; flags = 0; @@ -5229,19 +6275,18 @@ Perl_ck_fun(pTHX_ OP *o) else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) { - GV *gv = cGVOPx_gv(kUNOP->op_first); + GV * const gv = cGVOPx_gv(kUNOP->op_first); name = GvNAME(gv); len = GvNAMELEN(gv); } else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { - OP *op; - - name = 0; - if ((op = ((BINOP*)kid)->op_first)) { - SV *tmpstr = Nullsv; - char *a = + 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) || @@ -5249,7 +6294,7 @@ Perl_ck_fun(pTHX_ OP *o) (op = ((UNOP*)op)->op_first) && (op->op_type == OP_GV)) { /* packagevar $a[] or $h{} */ - GV *gv = cGVOPx_gv(op); + GV * const gv = cGVOPx_gv(op); if (gv) tmpstr = Perl_newSVpvf(aTHX_ @@ -5260,7 +6305,7 @@ Perl_ck_fun(pTHX_ OP *o) else if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) { /* lexicalvar $a[] or $h{} */ - char *padname = + const char * const padname = PAD_COMPNAME_PV(op->op_targ); if (padname) tmpstr = @@ -5268,10 +6313,9 @@ Perl_ck_fun(pTHX_ OP *o) "%s%c...%c", padname + 1, a[0], a[1]); - } if (tmpstr) { - name = SvPV(tmpstr, len); + name = SvPV_const(tmpstr, len); sv_2mortal(tmpstr); } } @@ -5285,7 +6329,7 @@ Perl_ck_fun(pTHX_ OP *o) SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); - (void)SvUPGRADE(namesv, SVt_PV); + SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); sv_catpvn(namesv, name, len); @@ -5309,14 +6353,28 @@ Perl_ck_fun(pTHX_ OP *o) tokid = &kid->op_sibling; kid = kid->op_sibling; } +#ifdef PERL_MAD + if (kid && kid->op_type != OP_STUB) + return too_many_arguments(o,OP_DESC(o)); + o->op_private |= numargs; +#else + /* FIXME - should the numargs move as for the PERL_MAD case? */ o->op_private |= numargs; if (kid) return too_many_arguments(o,OP_DESC(o)); +#endif listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { +#ifdef PERL_MAD + OP *newop = newUNOP(type, 0, newDEFSVOP()); + op_getmad(o,newop,'O'); + return newop; +#else + /* Ordering of these two is important to keep f_map.t passing. */ op_free(o); return newUNOP(type, 0, newDEFSVOP()); +#endif } if (oa) { @@ -5331,16 +6389,17 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { + dVAR; GV *gv; o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); - if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) + if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { - gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); } #if !defined(PERL_EXTERNAL_GLOB) @@ -5349,11 +6408,11 @@ Perl_ck_glob(pTHX_ OP *o) GV *glob_gv; ENTER; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); - gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); - glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); + newSVpvs("File::Glob"), NULL, NULL, NULL); + gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); + glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); - SvREFCNT_inc((SV*)GvCV(gv)); + SvREFCNT_inc_void((SV*)GvCV(gv)); GvIMPORTED_CV_on(gv); LEAVE; } @@ -5385,21 +6444,25 @@ Perl_ck_glob(pTHX_ OP *o) OP * Perl_ck_grep(pTHX_ OP *o) { - LOGOP *gwop; + dVAR; + LOGOP *gwop = NULL; OP *kid; - OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; I32 offset; o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; - NewOp(1101, gwop, 1, LOGOP); + /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */ if (o->op_flags & OPf_STACKED) { OP* k; o = ck_sort(o); kid = cLISTOPo->op_first->op_sibling; - for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) { + if (!cUNOPx(kid)->op_next) + Perl_croak(aTHX_ "panic: ck_grep"); + for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { kid = k; } + NewOp(1101, gwop, 1, LOGOP); kid->op_next = (OP*)gwop; o->op_flags &= ~OPf_STACKED; } @@ -5416,6 +6479,8 @@ Perl_ck_grep(pTHX_ OP *o) Perl_croak(aTHX_ "panic: ck_grep"); kid = kUNOP->op_first; + if (!gwop) + NewOp(1101, gwop, 1, LOGOP); gwop->op_type = type; gwop->op_ppaddr = PL_ppaddr[type]; gwop->op_first = listkids(o); @@ -5423,7 +6488,7 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; offset = pad_findmy("$_"); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { o->op_private = gwop->op_private = 0; gwop->op_targ = pad_alloc(type, SVs_PADTMP); } @@ -5464,7 +6529,7 @@ Perl_ck_lengthconst(pTHX_ OP *o) OP * Perl_ck_lfun(pTHX_ OP *o) { - OPCODE type = o->op_type; + const OPCODE type = o->op_type; return modkids(ck_fun(o), type); } @@ -5509,7 +6574,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ OP * Perl_ck_rfun(pTHX_ OP *o) { - OPCODE type = o->op_type; + const OPCODE type = o->op_type; return refkids(ck_fun(o), type); } @@ -5544,6 +6609,44 @@ Perl_ck_listiob(pTHX_ OP *o) } OP * +Perl_ck_say(pTHX_ OP *o) +{ + o = ck_listiob(o); + o->op_type = OP_PRINT; + cLISTOPo->op_last = cLISTOPo->op_last->op_sibling + = newSVOP(OP_CONST, 0, newSVpvs("\n")); + return o; +} + +OP * +Perl_ck_smartmatch(pTHX_ OP *o) +{ + dVAR; + if (0 == (o->op_flags & OPf_SPECIAL)) { + OP *first = cBINOPo->op_first; + OP *second = first->op_sibling; + + /* Implicitly take a reference to an array or hash */ + first->op_sibling = NULL; + first = cBINOPo->op_first = ref_array_or_hash(first); + second = first->op_sibling = ref_array_or_hash(second); + + /* Implicitly take a reference to a regular expression */ + if (first->op_type == OP_MATCH) { + first->op_type = OP_QR; + first->op_ppaddr = PL_ppaddr[OP_QR]; + } + if (second->op_type == OP_MATCH) { + second->op_type = OP_QR; + second->op_ppaddr = PL_ppaddr[OP_QR]; + } + } + + return o; +} + + +OP * Perl_ck_sassign(pTHX_ OP *o) { OP *kid = cLISTOPo->op_first; @@ -5553,7 +6656,7 @@ Perl_ck_sassign(pTHX_ OP *o) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY)) { - OP *kkid = kid->op_sibling; + OP * const kkid = kid->op_sibling; /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV @@ -5564,8 +6667,13 @@ Perl_ck_sassign(pTHX_ OP *o) /* Now we do not need PADSV and SASSIGN. */ kid->op_sibling = o->op_sibling; /* NULL */ cLISTOPo->op_first = NULL; +#ifdef PERL_MAD + op_getmad(o,kid,'O'); + op_getmad(kkid,kid,'M'); +#else op_free(o); op_free(kkid); +#endif kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } @@ -5576,9 +6684,10 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { - if (o->op_type != OP_QR) { - I32 offset = pad_findmy("$_"); - if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) { + dVAR; + if (o->op_type != OP_QR && PL_compcv) { + const I32 offset = pad_findmy("$_"); + if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; } @@ -5591,19 +6700,24 @@ Perl_ck_match(pTHX_ OP *o) OP * Perl_ck_method(pTHX_ OP *o) { - OP *kid = cUNOPo->op_first; + OP * const kid = cUNOPo->op_first; if (kid->op_type == OP_CONST) { SV* sv = kSVOP->op_sv; - if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { + const char * const method = SvPVX_const(sv); + if (!(strchr(method, ':') || strchr(method, '\''))) { OP *cmop; if (!SvREADONLY(sv) || !SvFAKE(sv)) { - sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0); + sv = newSVpvn_share(method, SvCUR(sv), 0); } else { - kSVOP->op_sv = Nullsv; + kSVOP->op_sv = NULL; } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); +#ifdef PERL_MAD + op_getmad(o,cmop,'O'); +#else op_free(o); +#endif return cmop; } } @@ -5613,28 +6727,28 @@ Perl_ck_method(pTHX_ OP *o) OP * Perl_ck_null(pTHX_ OP *o) { + PERL_UNUSED_CONTEXT; return o; } OP * Perl_ck_open(pTHX_ OP *o) { - HV *table = GvHV(PL_hintgv); + dVAR; + HV * const table = GvHV(PL_hintgv); if (table) { - SV **svp; - I32 mode; - svp = hv_fetch(table, "open_IN", 7, FALSE); + SV **svp = hv_fetchs(table, "open_IN", FALSE); if (svp && *svp) { - mode = mode_from_discipline(*svp); + const I32 mode = mode_from_discipline(*svp); if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; else if (mode & O_TEXT) o->op_private |= OPpOPEN_IN_CRLF; } - svp = hv_fetch(table, "open_OUT", 8, FALSE); + svp = hv_fetchs(table, "open_OUT", FALSE); if (svp && *svp) { - mode = mode_from_discipline(*svp); + const I32 mode = mode_from_discipline(*svp); if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; else if (mode & O_TEXT) @@ -5646,18 +6760,19 @@ Perl_ck_open(pTHX_ OP *o) { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ - OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ - OP *last = cLISTOPx(o)->op_last; /* The bareword. */ + OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ + OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ OP *oa; - char *mode; + const char *mode; if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && (oa = first->op_sibling) && /* The fh. */ (oa = oa->op_sibling) && /* The mode. */ + (oa->op_type == OP_CONST) && SvPOK(((SVOP*)oa)->op_sv) && - (mode = SvPVX(((SVOP*)oa)->op_sv)) && + (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ (last == oa->op_sibling)) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; @@ -5680,44 +6795,64 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { - GV* gv; + dVAR; + GV* gv = NULL; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP *kid = (SVOP*)cUNOPo->op_first; + SVOP * const kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + SV * const sv = kid->op_sv; + U32 was_readonly = SvREADONLY(sv); char *s; - for (s = SvPVX(kid->op_sv); *s; s++) { + + if (was_readonly) { + if (SvFAKE(sv)) { + sv_force_normal_flags(sv, 0); + assert(!SvREADONLY(sv)); + was_readonly = 0; + } else { + SvREADONLY_off(sv); + } + } + + for (s = SvPVX(sv); *s; s++) { if (*s == ':' && s[1] == ':') { + const STRLEN len = strlen(s+2)+1; *s = '/'; - Move(s+2, s+1, strlen(s+2)+1, char); - --SvCUR(kid->op_sv); + Move(s+2, s+1, len, char); + SvCUR_set(sv, SvCUR(sv) - 1); } } - if (SvREADONLY(kid->op_sv)) { - SvREADONLY_off(kid->op_sv); - sv_catpvn(kid->op_sv, ".pm", 3); - SvREADONLY_on(kid->op_sv); - } - else - sv_catpvn(kid->op_sv, ".pm", 3); + sv_catpvs(sv, ".pm"); + SvFLAGS(sv) |= was_readonly; } } - /* handle override, if any */ - gv = gv_fetchpv("require", FALSE, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) - gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); + if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */ + /* handle override, if any */ + gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV); + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { + GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE); + gv = gvp ? *gvp : NULL; + } + } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - OP *kid = cUNOPo->op_first; + OP * const kid = cUNOPo->op_first; + OP * newop; + cUNOPo->op_first = 0; +#ifndef PERL_MAD op_free(o); - return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, kid, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv)))))); +#endif + newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, kid, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + op_getmad(o,newop,'O'); + return newop; } return ck_fun(o); @@ -5726,27 +6861,19 @@ Perl_ck_require(pTHX_ OP *o) OP * Perl_ck_return(pTHX_ OP *o) { - OP *kid; + dVAR; if (CvLVALUE(PL_compcv)) { + OP *kid; for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); } return o; } -#if 0 -OP * -Perl_ck_retarget(pTHX_ OP *o) -{ - Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); - /* STUB */ - return o; -} -#endif - OP * Perl_ck_select(pTHX_ OP *o) { + dVAR; OP* kid; if (o->op_flags & OPf_KIDS) { kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ @@ -5767,15 +6894,26 @@ Perl_ck_select(pTHX_ OP *o) OP * Perl_ck_shift(pTHX_ OP *o) { - I32 type = o->op_type; + dVAR; + const I32 type = o->op_type; if (!(o->op_flags & OPf_KIDS)) { OP *argop; - + /* FIXME - this can be refactored to reduce code in #ifdefs */ +#ifdef PERL_MAD + OP *oldo = o; +#else op_free(o); +#endif argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); +#ifdef PERL_MAD + o = newUNOP(type, 0, scalar(argop)); + op_getmad(oldo,o,'O'); + return o; +#else return newUNOP(type, 0, scalar(argop)); +#endif } return scalar(modkids(ck_fun(o), type)); } @@ -5783,8 +6921,24 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + dVAR; OP *firstkid; + if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) + { + HV * const hinthv = GvHV(PL_hintgv); + if (hinthv) { + SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); + if (svp) { + const I32 sorthints = (I32)SvIV(*svp); + if ((sorthints & HINT_SORT_QUICKSORT) != 0) + o->op_private |= OPpSORT_QSORT; + if ((sorthints & HINT_SORT_STABLE) != 0) + o->op_private |= OPpSORT_STABLE; + } + } + } + if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ @@ -5846,14 +7000,16 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { + dVAR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; - int reversed; + int descending; GV *gv; + const char *gvname; if (!(o->op_flags & OPf_STACKED)) return; - GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); - GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); + GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); kid = kUNOP->op_first; /* get past null */ if (kid->op_type != OP_SCOPE) return; @@ -5876,12 +7032,14 @@ S_simplify_sort(pTHX_ OP *o) gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; - if (strEQ(GvNAME(gv), "a")) - reversed = 0; - else if (strEQ(GvNAME(gv), "b")) - reversed = 1; + gvname = GvNAME(gv); + if (*gvname == 'a' && gvname[1] == '\0') + descending = 0; + else if (*gvname == 'b' && gvname[1] == '\0') + descending = 1; else return; + kid = k; /* back to cmp */ if (kBINOP->op_last->op_type != OP_RV2SV) return; @@ -5890,26 +7048,33 @@ S_simplify_sort(pTHX_ OP *o) return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; - if (GvSTASH(gv) != PL_curstash - || ( reversed - ? strNE(GvNAME(gv), "a") - : strNE(GvNAME(gv), "b"))) + if (GvSTASH(gv) != PL_curstash) + return; + gvname = GvNAME(gv); + if ( descending + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); - if (reversed) - o->op_private |= OPpSORT_REVERSE; + if (descending) + o->op_private |= OPpSORT_DESCEND; if (k->op_type == OP_NCMP) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ +#ifdef PERL_MAD + op_getmad(kid,o,'S'); /* then delete it */ +#else op_free(kid); /* then delete it */ +#endif } OP * Perl_ck_split(pTHX_ OP *o) { + dVAR; register OP *kid; if (o->op_flags & OPf_STACKED) @@ -5922,14 +7087,14 @@ Perl_ck_split(pTHX_ OP *o) op_free(cLISTOPo->op_first); cLISTOPo->op_first = kid; if (!kid) { - cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1)); + cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); cLISTOPo->op_last = kid; /* There was only one element previously */ } if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { - OP *sibl = kid->op_sibling; + OP * const sibl = kid->op_sibling; kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); if (cLISTOPo->op_first == cLISTOPo->op_last) cLISTOPo->op_last = kid; cLISTOPo->op_first = kid; @@ -5939,7 +7104,7 @@ Perl_ck_split(pTHX_ OP *o) kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); - if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) { Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } @@ -5965,12 +7130,11 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - if (ckWARN(WARN_SYNTAX)) { - OP *kid = cLISTOPo->op_first->op_sibling; - if (kid && kid->op_type == OP_MATCH) { - char *pmstr = "STRING"; - if (PM_GETRE(kPMOP)) - pmstr = PM_GETRE(kPMOP)->precomp; + const OP * const kid = cLISTOPo->op_first->op_sibling; + if (kid && kid->op_type == OP_MATCH) { + if (ckWARN(WARN_SYNTAX)) { + const REGEXP *re = PM_GETRE(kPMOP); + const char *pmstr = re ? re->precomp : "STRING"; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%s/ should probably be written as \"%s\"", pmstr, pmstr); @@ -5980,57 +7144,21 @@ Perl_ck_join(pTHX_ OP *o) } OP * -Perl_ck_state(pTHX_ OP *o) -{ - /* warn on C , C<$a && my $x=1;> style statements */ - OP *kid; - o = o->op_sibling; - if (!o || o->op_type != OP_NULL || !(o->op_flags & OPf_KIDS)) - return o; - kid = cUNOPo->op_first; - if (!(kid->op_type == OP_AND || kid->op_type == OP_OR)) - return o; - kid = kUNOP->op_first->op_sibling; - if (kid->op_type == OP_SASSIGN) - kid = kBINOP->op_first->op_sibling; - else if (kid->op_type == OP_AASSIGN) - kid = kBINOP->op_first->op_sibling; - - if (kid->op_type == OP_LIST - || (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)) - { - kid = kUNOP->op_first; - if (kid->op_type == OP_PUSHMARK) - kid = kid->op_sibling; - } - if ((kid->op_type == OP_PADSV || kid->op_type == OP_PADAV - || kid->op_type == OP_PADHV) - && (kid->op_private & OPpLVAL_INTRO) - && (ckWARN(WARN_DEPRECATED))) - { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Deprecated use of my() in conditional"); - } - return o; -} - - -OP * Perl_ck_subr(pTHX_ OP *o) { + dVAR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; OP *cvop; - char *proto = 0; - CV *cv = 0; - GV *namegv = 0; + char *proto = NULL; + CV *cv = NULL; + GV *namegv = NULL; int optional = 0; I32 arg = 0; I32 contextclass = 0; - char *e = 0; - STRLEN n_a; - bool delete=0; + char *e = NULL; + bool delete_op = 0; o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; @@ -6047,7 +7175,7 @@ Perl_ck_subr(pTHX_ OP *o) else { if (SvPOK(cv)) { namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV((SV*)cv, n_a); + proto = SvPV_nolen((SV*)cv); } if (CvASSERTION(cv)) { if (PL_hints & HINT_ASSERTING) { @@ -6055,8 +7183,8 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_DB; } else { - delete=1; - if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { + delete_op = 1; + if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } @@ -6069,15 +7197,20 @@ Perl_ck_subr(pTHX_ OP *o) if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; else if (o2->op_type == OP_LIST) { - OP *o = ((UNOP*)o2)->op_first->op_sibling; - if (o && o->op_type == OP_CONST) - o->op_private &= ~OPpCONST_STRICT; + OP * const sib = ((UNOP*)o2)->op_first->op_sibling; + if (sib && sib->op_type == OP_CONST) + sib->op_private &= ~OPpCONST_STRICT; } } o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { + OP* o3; + if (PL_madskills && o2->op_type == OP_NULL) + o3 = ((UNOP*)o2)->op_first; + else + o3 = o2; if (proto) { switch (*proto) { case '\0': @@ -6099,22 +7232,22 @@ Perl_ck_subr(pTHX_ OP *o) case '&': proto++; arg++; - if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) + if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) bad_type(arg, arg == 1 ? "block or sub {}" : "sub {}", - gv_ename(namegv), o2); + gv_ename(namegv), o3); break; case '*': /* '*' allows any scalar type, including bareword */ proto++; arg++; - if (o2->op_type == OP_RV2GV) + if (o3->op_type == OP_RV2GV) goto wrapref; /* autoconvert GLOB -> GLOBref */ - else if (o2->op_type == OP_CONST) - o2->op_private &= ~OPpCONST_STRICT; - else if (o2->op_type == OP_ENTERSUB) { + else if (o3->op_type == OP_CONST) + o3->op_private &= ~OPpCONST_STRICT; + else if (o3->op_type == OP_ENTERSUB) { /* accidental subroutine, revert to bareword */ - OP *gvop = ((UNOP*)o2)->op_first; + OP *gvop = ((UNOP*)o3)->op_first; if (gvop && gvop->op_type == OP_NULL) { gvop = ((UNOP*)gvop)->op_first; if (gvop) { @@ -6125,14 +7258,17 @@ Perl_ck_subr(pTHX_ OP *o) (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { - GV *gv = cGVOPx_gv(gvop); - OP *sibling = o2->op_sibling; - SV *n = newSVpvn("",0); + GV * const gv = cGVOPx_gv(gvop); + OP * const sibling = o2->op_sibling; + SV * const n = newSVpvs(""); +#ifdef PERL_MAD + OP *oldo2 = o2; +#else op_free(o2); - gv_fullname3(n, gv, ""); - if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6)) - sv_chop(n, SvPVX(n)+6); +#endif + gv_fullname4(n, gv, "", FALSE); o2 = newSVOP(OP_CONST, 0, n); + op_getmad(oldo2,o2,'O'); prev->op_sibling = o2; o2->op_sibling = sibling; } @@ -6161,57 +7297,59 @@ Perl_ck_subr(pTHX_ OP *o) break; case ']': if (contextclass) { - char *p = proto; - char s = *p; + /* XXX We shouldn't be modifying proto, so we can const proto */ + char *p = proto; + const char s = *p; contextclass = 0; *p = '\0'; while (*--p != '['); bad_type(arg, Perl_form(aTHX_ "one of %s", p), - gv_ename(namegv), o2); + gv_ename(namegv), o3); *proto = s; } else goto oops; break; case '*': - if (o2->op_type == OP_RV2GV) + if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type(arg, "symbol", gv_ename(namegv), o2); + bad_type(arg, "symbol", gv_ename(namegv), o3); break; case '&': - if (o2->op_type == OP_ENTERSUB) + if (o3->op_type == OP_ENTERSUB) goto wrapref; if (!contextclass) - bad_type(arg, "subroutine entry", gv_ename(namegv), o2); + bad_type(arg, "subroutine entry", gv_ename(namegv), + o3); break; case '$': - if (o2->op_type == OP_RV2SV || - o2->op_type == OP_PADSV || - o2->op_type == OP_HELEM || - o2->op_type == OP_AELEM || - o2->op_type == OP_THREADSV) + if (o3->op_type == OP_RV2SV || + o3->op_type == OP_PADSV || + o3->op_type == OP_HELEM || + o3->op_type == OP_AELEM || + o3->op_type == OP_THREADSV) goto wrapref; if (!contextclass) - bad_type(arg, "scalar", gv_ename(namegv), o2); + bad_type(arg, "scalar", gv_ename(namegv), o3); break; case '@': - if (o2->op_type == OP_RV2AV || - o2->op_type == OP_PADAV) + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV) goto wrapref; if (!contextclass) - bad_type(arg, "array", gv_ename(namegv), o2); + bad_type(arg, "array", gv_ename(namegv), o3); break; case '%': - if (o2->op_type == OP_RV2HV || - o2->op_type == OP_PADHV) + if (o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV) goto wrapref; if (!contextclass) - bad_type(arg, "hash", gv_ename(namegv), o2); + bad_type(arg, "hash", gv_ename(namegv), o3); break; wrapref: { - OP* kid = o2; - OP* sib = kid->op_sibling; + OP* const kid = o2; + OP* const sib = kid->op_sibling; kid->op_sibling = 0; o2 = newUNOP(OP_REFGEN, 0, kid); o2->op_sibling = sib; @@ -6241,13 +7379,18 @@ Perl_ck_subr(pTHX_ OP *o) mod(o2, OP_ENTERSUB); prev = o2; o2 = o2->op_sibling; - } + } /* while */ if (proto && !optional && (*proto && *proto != '@' && *proto != '%' && *proto != ';')) return too_few_arguments(o, gv_ename(namegv)); - if(delete) { + if(delete_op) { +#ifdef PERL_MAD + OP *oldo = o; +#else op_free(o); +#endif o=newSVOP(OP_CONST, 0, newSViv(0)); + op_getmad(oldo,o,'O'); } return o; } @@ -6255,11 +7398,28 @@ Perl_ck_subr(pTHX_ OP *o) OP * Perl_ck_svconst(pTHX_ OP *o) { + PERL_UNUSED_CONTEXT; SvREADONLY_on(cSVOPo->op_sv); return o; } OP * +Perl_ck_chdir(pTHX_ OP *o) +{ + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; + + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { + o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; + } + } + return ck_fun(o); +} + +OP * Perl_ck_trunc(pTHX_ OP *o) { if (o->op_flags & OPf_KIDS) { @@ -6305,12 +7465,15 @@ Perl_ck_substr(pTHX_ OP *o) return o; } -/* A peephole optimizer. We visit the ops in the order they're to execute. */ +/* A peephole optimizer. We visit the ops in the order they're to execute. + * See the comments at the top of this file for more details about when + * peep() is called */ void Perl_peep(pTHX_ register OP *o) { - register OP* oldop = 0; + dVAR; + register OP* oldop = NULL; if (!o || o->op_opt) return; @@ -6338,7 +7501,7 @@ Perl_peep(pTHX_ register OP *o) * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { - PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); + const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ @@ -6346,6 +7509,18 @@ Perl_peep(pTHX_ register OP *o) SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } + else if (o->op_type == OP_CONST + && cSVOPo->op_sv == &PL_sv_undef) { + /* PL_sv_undef is hack - it's unsafe to store it in the + AV that is the pad, because av_fetch treats values of + PL_sv_undef as a "free" AV entry and will merrily + replace them with a new SV, causing pad_alloc to think + that this pad slot is free. (When, clearly, it is not) + */ + SvOK_off(PAD_SVl(ix)); + SvPADTMP_on(PAD_SVl(ix)); + SvREADONLY_on(PAD_SVl(ix)); + } else { SvREFCNT_dec(PAD_SVl(ix)); SvPADTMP_on(cSVOPo->op_sv); @@ -6353,7 +7528,7 @@ Perl_peep(pTHX_ register OP *o) /* XXX I don't know how this isn't readonly already. */ SvREADONLY_on(PAD_SVl(ix)); } - cSVOPo->op_sv = Nullsv; + cSVOPo->op_sv = NULL; o->op_targ = ix; } #endif @@ -6414,11 +7589,11 @@ Perl_peep(pTHX_ register OP *o) case OP_PADAV: case OP_GV: if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { - OP* pop = (o->op_type == OP_PADAV) ? + 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) && + ((PL_op = pop->op_next)) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && @@ -6427,6 +7602,8 @@ Perl_peep(pTHX_ register OP *o) i >= 0) { 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); @@ -6458,11 +7635,11 @@ Perl_peep(pTHX_ register OP *o) } } else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { - GV *gv = cGVOPo_gv; - if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { + GV * const gv = cGVOPo_gv; + if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ - SV *sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); + SV * const sv = sv_newmortal(); + gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", sv); @@ -6525,13 +7702,14 @@ Perl_peep(pTHX_ register OP *o) case OP_EXEC: o->op_opt = 1; - if (ckWARN(WARN_SYNTAX) && o->op_next - && o->op_next->op_type == OP_NEXTSTATE) { + if (o->op_next && o->op_next->op_type == OP_NEXTSTATE + && ckWARN(WARN_SYNTAX)) + { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_EXIT && o->op_next->op_sibling->op_type != OP_WARN && o->op_next->op_sibling->op_type != OP_DIE) { - line_t oldline = CopLINE(PL_curcop); + const line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); Perl_warner(aTHX_ packWARN(WARN_EXEC), @@ -6544,9 +7722,11 @@ Perl_peep(pTHX_ register OP *o) break; case OP_HELEM: { + UNOP *rop; SV *lexname; + GV **fields; SV **svp, *sv; - char *key = NULL; + const char *key = NULL; STRLEN keylen; o->op_opt = 1; @@ -6557,29 +7737,128 @@ Perl_peep(pTHX_ register OP *o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { - key = SvPV(sv, keylen); + key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : keylen, 0); SvREFCNT_dec(sv); *svp = lexname; } + + if ((o->op_private & (OPpLVAL_INTRO))) + break; + + rop = (UNOP*)((BINOP*)o)->op_first; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); + if (!SvPAD_TYPED(lexname)) + break; + fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); + if (!fields || !GvHV(*fields)) + break; + key = SvPV_const(*svp, keylen); + if (!hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + { + Perl_croak(aTHX_ "No such class field \"%s\" " + "in variable %s of type %s", + key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); + } + break; } - case OP_SORT: { - /* make @a = sort @a act in-place */ + case OP_HSLICE: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp; + const char *key; + STRLEN keylen; + SVOP *first_key_op, *key_op; + if ((o->op_private & (OPpLVAL_INTRO)) + /* I bet there's always a pushmark... */ + || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) + /* hmmm, no optimization if list contains only one key. */ + break; + rop = (UNOP*)((LISTOP*)o)->op_last; + if (rop->op_type != OP_RV2HV) + break; + if (rop->op_first->op_type == OP_PADSV) + /* @$hash{qw(keys here)} */ + rop = (UNOP*)rop->op_first; + else { + /* @{$hash}{qw(keys here)} */ + if (rop->op_first->op_type == OP_SCOPE + && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) + { + rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; + } + else + break; + } + + lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); + if (!SvPAD_TYPED(lexname)) + break; + fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); + if (!fields || !GvHV(*fields)) + break; + /* Again guessing that the pushmark can be jumped over.... */ + first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) + ->op_first->op_sibling; + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) { + if (key_op->op_type != OP_CONST) + continue; + svp = cSVOPx_svp(key_op); + key = SvPV_const(*svp, keylen); + if (!hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + { + Perl_croak(aTHX_ "No such class field \"%s\" " + "in variable %s of type %s", + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); + } + } + break; + } + + case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ - OP *oleft, *oright; + OP *oleft; OP *o2; - o->op_opt = 1; - /* check that RHS of sort is a single plain array */ - oright = cUNOPo->op_first; + OP *oright = cUNOPo->op_first; if (!oright || oright->op_type != OP_PUSHMARK) break; + + /* reverse sort ... can be optimised. */ + if (!cUNOPo->op_sibling) { + /* 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) + && (cUNOPx(pushmark)->op_sibling == o)) { + /* reverse -> pushmark -> sort */ + o->op_private |= OPpSORT_REVERSE; + op_null(reverse); + pushmark->op_next = oright->op_next; + op_null(oright); + } + } + } + + /* make @a = sort @a act in-place */ + + o->op_opt = 1; + oright = cUNOPx(oright)->op_sibling; if (!oright) break; @@ -6619,6 +7898,17 @@ Perl_peep(pTHX_ register OP *o) || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) break; + /* check that the sort is the first arg on RHS of assign */ + + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_NULL) + break; + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_PUSHMARK) + break; + if (o2->op_sibling != o) + break; + /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { if (oright->op_type != OP_RV2AV @@ -6654,9 +7944,149 @@ Perl_peep(pTHX_ register OP *o) break; } - + case OP_REVERSE: { + OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; + OP *gvop = NULL; + LISTOP *enter, *exlist; + o->op_opt = 1; + + 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 *) expushmark->op_sibling; + 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 (theirmark->op_sibling != 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 = ourmark->op_sibling; + if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 + && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) + && enter->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; + + break; + } + + case OP_SASSIGN: { + OP *rv2gv; + UNOP *refgen, *rv2cv; + LISTOP *exlist; + + /* I do not understand this, but if o->op_opt isn't set to 1, + various tests in ext/B/t/bytecode.t fail with no readily + apparent cause. */ + + o->op_opt = 1; + + + if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID) + break; + + if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) + break; + + rv2gv = ((BINOP *)o)->op_last; + if (!rv2gv || rv2gv->op_type != OP_RV2GV) + break; + + refgen = (UNOP *)((BINOP *)o)->op_first; + + if (!refgen || refgen->op_type != OP_REFGEN) + break; + + exlist = (LISTOP *)refgen->op_first; + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_first->op_type != OP_PUSHMARK) + break; + + rv2cv = (UNOP*)exlist->op_last; + + if (rv2cv->op_type != OP_RV2CV) + break; + + assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); + assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); + assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); + + o->op_private |= OPpASSIGN_CV_TO_GV; + rv2gv->op_private |= OPpDONT_INIT_GV; + rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; + + break; + } + + default: o->op_opt = 1; break; @@ -6666,59 +8096,72 @@ Perl_peep(pTHX_ register OP *o) LEAVE; } - - -char* Perl_custom_op_name(pTHX_ OP* o) +char* +Perl_custom_op_name(pTHX_ const OP* o) { - IV index = PTR2IV(o->op_ppaddr); + dVAR; + const IV index = PTR2IV(o->op_ppaddr); SV* keysv; HE* he; if (!PL_custom_op_names) /* This probably shouldn't happen */ - return PL_op_name[OP_CUSTOM]; + return (char *)PL_op_name[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); if (!he) - return PL_op_name[OP_CUSTOM]; /* Don't know who you are */ + return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ return SvPV_nolen(HeVAL(he)); } -char* Perl_custom_op_desc(pTHX_ OP* o) +char* +Perl_custom_op_desc(pTHX_ const OP* o) { - IV index = PTR2IV(o->op_ppaddr); + dVAR; + const IV index = PTR2IV(o->op_ppaddr); SV* keysv; HE* he; if (!PL_custom_op_descs) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); if (!he) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; return SvPV_nolen(HeVAL(he)); } - #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ static void const_sv_xsub(pTHX_ CV* cv) { + dVAR; dXSARGS; if (items != 0) { + /*EMPTY*/; #if 0 Perl_croak(aTHX_ "usage: %s::%s()", - HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); + HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } EXTEND(sp, 1); ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */