recursive, but it's recursive on basic blocks, not on tree nodes.
*/
+/* To implement user lexical pragmas, there needs to be a way at run time to
+ get the compile time state of %^H for that block. Storing %^H in every
+ block (or even COP) would be very expensive, so a different approach is
+ taken. The (running) state of %^H is serialised into a tree of HE-like
+ structs. Stores into %^H are chained onto the current leaf as a struct
+ refcounted_he * with the key and the value. Deletes from %^H are saved
+ with a value of PL_sv_placeholder. The state of %^H at any point can be
+ turned back into a regular HV by walking back up the tree from that point's
+ leaf, ignoring any key you've already seen (placeholder or not), storing
+ the rest into the HV structure, then removing the placeholders. Hence
+ memory is only used to store the %^H deltas from the enclosing COP, rather
+ than the entire %^H on each COP.
+
+ To cause actions on %^H to write out the serialisation records, it has
+ magic type 'H'. This magic (itself) does nothing, but its presence causes
+ the values to gain magic type 'h', which has entries for set and clear.
+ C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ saves the current C<PL_compiling.cop_hints> on the save stack, so that it
+ will be correctly restored when any inner compiling scope is exited.
+*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
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));
+ (void*)cSVOPo_sv));
}
/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ char *name)
+Perl_allocmy(pTHX_ const char *const name)
{
dVAR;
PADOFFSET off;
{
/* 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;
- p = strchr(name, '\0');
- /* The next block assumes the buffer is at least 205 chars
- long. At present, it's always at least 256 chars. */
- if (p-name > 200) {
- strcpy(name+200, "...");
- p = name+199;
- }
- else {
- p[1] = '\0';
- }
- /* Move everything else down one character */
- for (; p-name > 2; p--)
- *p = *(p-1);
- name[2] = toCTRL(name[1]);
- name[1] = '^';
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
+ name[0], toCTRL(name[1]), name + 2));
+ } else {
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
/* check for duplicate declaration */
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, is_our ? "our" : "my"));
+ name,
+ is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
}
/* allocate a spare slot and store the name in that slot */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
),
- 0 /* not fake */
+ 0, /* not fake */
+ PL_in_my == KEY_state
);
return off;
}
#ifdef PERL_MAD
/* if (o->op_madprop && o->op_madprop->mad_next)
abort(); */
- mad_free(o->op_madprop);
- o->op_madprop = 0;
+ /* 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:
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
+ PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
- /*EMPTY*/
+ NOOP;
#else
SvREFCNT_dec(cop->cop_io);
#endif
}
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints);
}
void
if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (o->op_private & OPpCONST_ARYBASE)
- useless = 0;
+ useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = 0;
+ useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
- useless = 0;
+ useless = NULL;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
(before the invention of POD) was based on a
if (strnEQ(maybe_macro, "di", 2) ||
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
- useless = 0;
+ useless = NULL;
}
}
}
{
dVAR;
if (o) {
- if (o->op_type == OP_LINESEQ ||
- o->op_type == OP_SCOPE ||
- o->op_type == OP_LEAVE ||
- o->op_type == OP_LEAVETRY)
+ const OPCODE type = o->op_type;
+
+ if (type == OP_LINESEQ || type == OP_SCOPE ||
+ type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
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);
+ CopARYBASE_set(&PL_compiling,
+ (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
PL_eval_start = 0;
}
else if (!type) {
- SAVEI32(PL_compiling.cop_arybase);
- PL_compiling.cop_arybase = 0;
+ SAVECOPARYBASE(&PL_compiling);
+ CopARYBASE_set(&PL_compiling, 0);
}
else if (type == OP_REFGEN)
goto nomod;
CV *cv;
OP *okid;
- if (kid->op_type == OP_PUSHMARK)
- goto skip_kids;
- if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "args: type/targ %ld:%"UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid = kLISTOP->op_first;
- skip_kids:
+ if (kid->op_type != OP_PUSHMARK) {
+ if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "args: type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
+ kid = kLISTOP->op_first;
+ }
while (kid->op_sibling)
kid = kid->op_sibling;
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
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;
+ rop = NULL;
#endif
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
/* Don't force the C<use> if we don't need it. */
SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
- /*EMPTY*/; /* already in %INC */
+ NOOP; /* already in %INC */
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs(ATTRSMODULE), NULL);
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;
}
- type = o->op_type;
if (type == OP_LIST) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
- OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+ OP_DESC(o),
+ PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : "my"));
+ PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
+ if (PL_in_my == KEY_state)
+ o->op_private |= OPpPAD_STATE;
return o;
}
{
OP *o;
bool ismatchop = 0;
+ const OPCODE ltype = left->op_type;
+ const OPCODE rtype = right->op_type;
- if ( (left->op_type == OP_RV2AV ||
- left->op_type == OP_RV2HV ||
- left->op_type == OP_PADAV ||
- left->op_type == OP_PADHV)
- && ckWARN(WARN_MISC))
+ if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
+ || ltype == 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 * const sample = ((left->op_type == OP_RV2AV ||
- left->op_type == OP_PADAV)
- ? "@array" : "%hash");
+ const char * const desc
+ = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+ ? rtype : OP_MATCH];
+ const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ ? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
}
- if (right->op_type == OP_CONST &&
+ if (rtype == OP_CONST &&
cSVOPx(right)->op_private & OPpCONST_BARE &&
cSVOPx(right)->op_private & OPpCONST_STRICT)
{
no_bareword_allowed(right);
}
- ismatchop = right->op_type == OP_MATCH ||
- right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS;
+ ismatchop = rtype == OP_MATCH ||
+ rtype == OP_SUBST ||
+ rtype == OP_TRANS;
if (ismatchop && right->op_private & OPpTARGET_MY) {
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
+ OP *newleft;
+
right->op_flags |= OPf_STACKED;
- if (right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
+ if (rtype != OP_MATCH &&
+ ! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL))
- left = mod(left, right->op_type);
+ newleft = mod(left, rtype);
+ else
+ newleft = left;
if (right->op_type == OP_TRANS)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
else
- o = prepend_elem(right->op_type, scalar(left), right);
+ o = prepend_elem(rtype, scalar(newleft), right);
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
Perl_invert(pTHX_ OP *o)
{
if (!o)
- return o;
- /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return NULL;
return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVESPTR(PL_compiling.cop_warnings);
- if (! specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
- }
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
SAVESPTR(PL_compiling.cop_io);
if (! specialCopIO(PL_compiling.cop_io)) {
PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
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);
+ CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
S_newDEFSVOP(pTHX)
{
dVAR;
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
#if 0
list(o);
#else
- /*EMPTY*/;
+ NOOP;
#endif
else {
if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : "my")
+ lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
: "local");
}
}
{
if (o->op_type == OP_LIST) {
OP * const o2
- = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
- SVt_PV)));
+ = 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;
register OP *curop;
OP *newop;
I32 type = o->op_type;
- SV *sv;
+ SV *sv = NULL;
+ int ret = 0;
+ I32 oldscope;
+ OP *old_next;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
+ dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if ((curop->op_type != OP_CONST ||
- (curop->op_private & OPpCONST_BARE)) &&
- curop->op_type != OP_LIST &&
- curop->op_type != OP_SCALAR &&
- curop->op_type != OP_NULL &&
- curop->op_type != OP_PUSHMARK)
+ const OPCODE type = curop->op_type;
+ if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
+ type != OP_LIST &&
+ type != OP_SCALAR &&
+ type != OP_NULL &&
+ type != OP_PUSHMARK)
{
goto nope;
}
}
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
PL_op = curop;
- CALLRUNOPS(aTHX);
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- SvREFCNT_inc_simple_void(sv);
- SvTEMP_off(sv);
- }
+
+ oldscope = PL_scopestack_ix;
+ create_eval_scope(G_FAKINGEVAL);
+
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ PL_diehook = NULL;
+ JMPENV_PUSH(ret);
+
+ switch (ret) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ, FALSE);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ SvREFCNT_inc_simple_void(sv);
+ SvTEMP_off(sv);
+ }
+ break;
+ case 3:
+ /* Something tried to die. Abandon constant folding. */
+ /* Pretend the error never happened. */
+ sv_setpvn(ERRSV,"",0);
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ /* XXX note that this croak may fail as we've already blown away
+ * the stack - eg any nested evals */
+ Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
+ }
+ JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
+
+ if (ret)
+ goto nope;
#ifndef PERL_MAD
op_free(o);
#endif
+ assert(sv);
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, (GV*)sv);
else
op_getmad(o,newop,'f');
return newop;
- nope:
+ nope:
return o;
}
Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
{
TOKEN *tk;
- Newz(1101, tk, 1, TOKEN);
+ Newxz(tk, 1, TOKEN);
tk->tk_type = (OPCODE)optype;
tk->tk_type = 12345;
tk->tk_lval = lval;
}
}
else {
- PerlIO_printf(PerlIO_stderr(), "DESTROYING op = %0x\n", from);
+ PerlIO_printf(PerlIO_stderr(),
+ "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
op_free(from);
}
}
Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
{
MADPROP *mp;
- Newz(1101, mp, 1, MADPROP);
+ Newxz(mp, 1, MADPROP);
mp->mad_next = 0;
mp->mad_key = key;
mp->mad_vlen = vlen;
const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
+ const U32 flags = UTF8_ALLOW_DEFAULT;
if (!from_utf) {
STRLEN len = tlen;
i = 0;
transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
}
else {
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
}
else
repl_has_vars = 1;
}
else if (curop->op_type == OP_PUSHRE)
- /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
+ NOOP; /* Okay here, dangerous in newASSIGNOP */
else
break;
}
#else
if (!PL_madskills) {
op_free(o);
- return Nullop;
+ return NULL;
}
pegop = newOP(OP_NULL,0);
if (!PL_madskills) {
/* FIXME - don't allocate pegop if !PL_madskills */
op_free(pegop);
- return Nullop;
+ return NULL;
}
return pegop;
#endif
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ newGVOP(OP_GV, 0, gv))))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
STATIC I32
S_is_list_assignment(pTHX_ register const OP *o)
{
+ unsigned type;
+ U8 flags;
+
if (!o)
return TRUE;
- if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
+ if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
o = cUNOPo->op_first;
- if (o->op_type == OP_COND_EXPR) {
+ flags = o->op_flags;
+ type = o->op_type;
+ if (type == OP_COND_EXPR) {
const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
return FALSE;
}
- if (o->op_type == OP_LIST &&
- (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+ if (type == OP_LIST &&
+ (flags & OPf_WANT) == OPf_WANT_SCALAR &&
o->op_private & OPpLVAL_INTRO)
return FALSE;
- if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
- o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
- o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
+ if (type == OP_LIST || flags & OPf_PARENS ||
+ type == OP_RV2AV || type == OP_RV2HV ||
+ type == OP_ASLICE || type == OP_HSLICE)
return TRUE;
- if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
+ if (type == OP_PADAV || type == OP_PADHV)
return TRUE;
- if (o->op_type == OP_RV2SV)
+ if (type == OP_RV2SV)
return FALSE;
return FALSE;
o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT) {
- OP* tmpop;
- if ((tmpop = ((LISTOP*)right)->op_first) &&
- tmpop->op_type == OP_PUSHRE)
- {
+ OP* tmpop = ((LISTOP*)right)->op_first;
+ if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
if (left->op_type == OP_RV2AV &&
!(left->op_private & OPpLVAL_INTRO) &&
else {
/* FIXME for MAD */
op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
o->op_private |= OPpCONST_ARYBASE;
}
}
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = (U8)flags;
- cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(cop, PL_hints);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- PL_compiling.op_private = cop->op_private;
+ CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
if (label) {
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
- cop->cop_arybase = PL_curcop->cop_arybase;
- if (specialWARN(PL_curcop->cop_warnings))
- cop->cop_warnings = PL_curcop->cop_warnings ;
- else
- cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
if (specialCopIO(PL_curcop->cop_io))
cop->cop_io = PL_curcop->cop_io;
else
cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+ cop->cop_hints = PL_curcop->cop_hints;
+ if (cop->cop_hints) {
+ HINTS_REFCNT_LOCK;
+ cop->cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
if (PL_copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
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;
}
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;
}
cont = append_elem(OP_LINESEQ, cont, unstack);
}
+ assert(block);
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
+ assert(listop);
redo = LINKLIST(listop);
if (expr) {
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
- OP *madsv = 0;
+ OP *madsv = NULL;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags |= OPpITER_DEF;
}
else {
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
* set the STACKED flag to indicate that these values are to be
* treated as min/max values by 'pp_iterinit'.
*/
- UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
OP* const right = left->op_sibling;
loop = tmp;
}
#else
- Renew(loop, 1, LOOP);
+ loop = PerlMemShared_realloc(loop, sizeof(LOOP));
#endif
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
*/
STATIC
bool
-S_looks_like_bool(pTHX_ OP *o)
+S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
switch(o->op_type) {
OP *
Perl_newWHENOP(pTHX_ OP *cond, OP *block)
{
- bool cond_llb = (!cond || looks_like_bool(cond));
+ const bool cond_llb = (!cond || looks_like_bool(cond));
OP *cond_op;
if (cond_llb)
}
void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len)
+{
+ /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+ relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
+ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
+ || (p && (len != SvCUR(cv) /* Not the same length. */
+ || memNE(p, SvPVX_const(cv), len))))
+ && ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
gv_efullname3(name = sv_newmortal(), gv, NULL);
sv_setpv(msg, "Prototype mismatch:");
if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+ Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
}
}
#endif
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
-#ifdef PERL_MAD
- /* FIXME for MAD - shouldn't this be done at the return statement? And
- given that the return statement is never reached, surely this currently
- is a leak? */
+#if 0
+ /* This would be the return value, but the return cannot be reached. */
OP* pegop = newOP(OP_NULL, 0);
#endif
SAVEFREEOP(block);
Perl_croak(aTHX_ "\"my sub\" not yet implemented");
#ifdef PERL_MAD
- return pegop;
+ NORETURN_FUNCTION_END;
#endif
}
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto((CV*)gv, NULL, ps);
+ cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
}
if (ps)
sv_setpvn((SV*)gv, ps, ps_len);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto(cv, gv, ps);
+ cv_ckproto_len(cv, gv, ps, ps_len);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if ((!block
}
}
if (const_sv) {
- SvREFCNT_inc_void_NN(const_sv);
+ SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
* before we clobber PL_compcv.
*/
- if (cv && !(block
+ if (cv && (!block
#ifdef PERL_MAD
|| block->op_type == OP_NULL
#endif
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, ERRSV);
+ Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
}
}
}
else {
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
- OP* newblock = newSTATEOP(0, NULL, 0);
+ OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
#else
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
{
dVAR;
CV* cv;
+#ifdef USE_ITHREADS
+ const char *const temp_p = CopFILE(PL_curcop);
+ const STRLEN len = temp_p ? strlen(temp_p) : 0;
+#else
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ STRLEN len;
+ const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+ char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+ /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ and so doesn't get free()d. (It's expected to be from the C pre-
+ processor __FILE__ directive). But we need a dynamically allocated one,
+ and we need it to get freed. */
+ cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
#ifdef USE_ITHREADS
if (stash)
return cv;
}
+CV *
+Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
+ const char *const filename, const char *const proto,
+ U32 flags)
+{
+ CV *cv = newXS(name, subaddr, filename);
+
+ if (flags & XS_DYNAMIC_FILENAME) {
+ /* We need to "make arrangements" (ie cheat) to ensure that the
+ filename lasts as long as the PVCV we just created, but also doesn't
+ leak */
+ STRLEN filename_len = strlen(filename);
+ STRLEN proto_and_file_len = filename_len;
+ char *proto_and_file;
+ STRLEN proto_len;
+
+ if (proto) {
+ proto_len = strlen(proto);
+ proto_and_file_len += proto_len;
+
+ Newx(proto_and_file, proto_and_file_len + 1, char);
+ Copy(proto, proto_and_file, proto_len, char);
+ Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
+ } else {
+ proto_len = 0;
+ proto_and_file = savepvn(filename, filename_len);
+ }
+
+ /* This gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ SV_HAS_TRAILING_NUL);
+ if (proto) {
+ /* This gives us the correct prototype, rather than one with the
+ file name appended. */
+ SvCUR_set(cv, proto_len);
+ } else {
+ SvPOK_off(cv);
+ }
+ CvFILE(cv) = proto_and_file + proto_len;
+ } else {
+ sv_setpv((SV *)cv, proto);
+ }
+ return cv;
+}
+
/*
=for apidoc U||newXS
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
=cut
*/
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined" ,cSVOPo->op_sv);
+ : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
{
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
return o;
}
o = modkids(ck_fun(o), type);
kid = cUNOPo->op_first;
newop = kUNOP->op_first->op_sibling;
- if (newop &&
- (newop->op_sibling ||
- !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
- newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
- newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
- return o;
+ if (newop) {
+ const OPCODE type = newop->op_type;
+ if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
+ type == OP_PADAV || type == OP_PADHV ||
+ type == OP_RV2AV || type == OP_RV2HV)
+ return o;
}
#ifdef PERL_MAD
op_getmad(kUNOP->op_first,newop,'K');
Perl_ck_eof(pTHX_ OP *o)
{
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));
+ OP * const newop
+ = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
#ifdef PERL_MAD
op_getmad(o,newop,'O');
#else
else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#endif
cUNOPo->op_first = 0;
}
else {
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#else
op_free(o);
#endif
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)));
+ OP *hhop = newSVOP(OP_CONST, 0,
+ (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
}
if (badthing)
Perl_croak(aTHX_
- "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
- kidsv, badthing);
+ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ (void*)kidsv, badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
const I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
- /*EMPTY*/;
+ NOOP;
}
else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ const OPCODE kidtype = kid->op_type;
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
#else
op_free(o);
#endif
- o = newop;
- return o;
+ return newop;
}
- else {
- if ((PL_hints & HINT_FILETEST_ACCESS) &&
- OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
- }
- if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
- && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+ if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT)
o->op_private |= OPpFT_STACKED;
}
else {
#ifdef PERL_MAD
- OP* oldo = o;
+ OP* const oldo = o;
#else
op_free(o);
#endif
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
+ OP *firstop;
OP *op = ((BINOP*)kid)->op_first;
name = NULL;
if (op) {
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op->op_type == OP_RV2HV)) &&
- (op = ((UNOP*)op)->op_first) &&
- (op->op_type == OP_GV)) {
+ (firstop = ((UNOP*)op)->op_first) &&
+ (firstop->op_type == OP_GV)) {
/* packagevar $a[] or $h{} */
- GV * const gv = cGVOPx_gv(op);
+ GV * const gv = cGVOPx_gv(firstop);
if (gv)
tmpstr =
Perl_newSVpvf(aTHX_
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) {
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop;
+ LOGOP *gwop = NULL;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- I32 offset;
+ PADOFFSET 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;
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;
}
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);
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
- OP *kid = cLISTOPo->op_first;
+ OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
return kid;
}
}
+ if (kid->op_sibling) {
+ OP *kkid = kid->op_sibling;
+ if (kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO)
+ && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+ }
+ }
return o;
}
{
dVAR;
if (o->op_type != OP_QR && PL_compcv) {
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
OP * const kid = cUNOPo->op_first;
- OP * newop
- = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ OP * newop;
+
cUNOPo->op_first = 0;
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
+#ifndef PERL_MAD
op_free(o);
#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;
}
OP *argop;
/* FIXME - this can be refactored to reduce code in #ifdefs */
#ifdef PERL_MAD
- OP *oldo = o;
+ OP * const oldo = o;
#else
op_free(o);
#endif
dVAR;
OP *firstkid;
- if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
- {
+ 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 (!kid->op_sibling)
append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ assert(kid->op_sibling);
kid = kid->op_sibling;
scalar(kid);
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
OP *cvop;
- char *proto = NULL;
+ const char *proto = NULL;
+ const char *proto_end = NULL;
CV *cv = NULL;
GV *namegv = NULL;
int optional = 0;
tmpop->op_private |= OPpEARLY_CV;
else {
if (SvPOK(cv)) {
+ STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV_nolen((SV*)cv);
+ proto = SvPV((SV*)cv, len);
+ proto_end = proto + len;
}
if (CvASSERTION(cv)) {
if (PL_hints & HINT_ASSERTING) {
else
o3 = o2;
if (proto) {
- switch (*proto) {
- case '\0':
+ if (proto >= proto_end)
return too_many_arguments(o, gv_ename(namegv));
+
+ switch (*proto) {
case ';':
optional = 1;
proto++;
OP * const sibling = o2->op_sibling;
SV * const n = newSVpvs("");
#ifdef PERL_MAD
- OP *oldo2 = o2;
+ OP * const oldo2 = o2;
#else
op_free(o2);
#endif
break;
case ']':
if (contextclass) {
- /* XXX We shouldn't be modifying proto, so we can const proto */
- char *p = proto;
- const char s = *p;
+ const char *p = proto;
+ const char *const end = proto;
contextclass = 0;
- *p = '\0';
while (*--p != '[');
- bad_type(arg, Perl_form(aTHX_ "one of %s", p),
- gv_ename(namegv), o3);
- *proto = s;
+ bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ (int)(end - p), p),
+ gv_ename(namegv), o3);
} else
goto oops;
break;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), cv);
+ gv_ename(namegv), (void*)cv);
}
}
else
prev = o2;
o2 = o2->op_sibling;
} /* while */
- if (proto && !optional &&
- (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ if (proto && !optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
- OP *oldo = o;
+ OP * const oldo = o;
#else
op_free(o);
#endif
Perl_ck_chdir(pTHX_ OP *o)
{
if (o->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid && kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
Perl_ck_substr(pTHX_ OP *o)
{
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
+ if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
+ (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
<= 255 &&
i >= 0)
{
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
- sv);
+ (void*)sv);
}
}
else if (o->op_next->op_type == OP_READLINE
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) {
- const line_t oldline = CopLINE(PL_curcop);
-
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "Statement unlikely to be reached");
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "\t(Maybe you meant system() when you said exec()?)\n");
- CopLINE_set(PL_curcop, oldline);
+ if (o->op_next->op_sibling) {
+ const OPCODE type = o->op_next->op_sibling->op_type;
+ if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
+ const line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "Statement unlikely to be reached");
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "\t(Maybe you meant system() when you said exec()?)\n");
+ CopLINE_set(PL_curcop, oldline);
+ }
}
}
break;
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : keylen,
+ SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
0);
SvREFCNT_dec(sv);
*svp = lexname;
break;
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
svp = cSVOPx_svp(key_op);
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
dVAR;
dXSARGS;
if (items != 0) {
- /*EMPTY*/;
+ NOOP;
#if 0
Perl_croak(aTHX_ "usage: %s::%s()",
HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
https://perl5.git.perl.org / perl5.git / blobdiff