#if defined(PL_OP_SLAB_ALLOC)
+#ifdef PERL_DEBUG_READONLY_OPS
+# define PERL_SLAB_SIZE 4096
+# include <sys/mman.h>
+#endif
+
#ifndef PERL_SLAB_SIZE
#define PERL_SLAB_SIZE 2048
#endif
void *
-Perl_Slab_Alloc(pTHX_ int m, size_t sz)
+Perl_Slab_Alloc(pTHX_ size_t sz)
{
/*
* To make incrementing use count easy PL_OpSlab is an I32 *
*/
sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
if ((PL_OpSpace -= sz) < 0) {
- PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* We need to allocate chunk by chunk so that we can control the VM
+ mapping */
+ PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0);
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
+ (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
+ PL_OpPtr));
+ if(PL_OpPtr == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+#else
+
+ PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
+#endif
if (!PL_OpPtr) {
return NULL;
}
- Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
/* We reserve the 0'th I32 sized chunk as a use count */
PL_OpSlab = (I32 *) PL_OpPtr;
/* Reduce size by the use count word, and by the size we need.
means that at run time access is cache friendly upward
*/
PL_OpPtr += PERL_SLAB_SIZE;
+
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* We remember this slab. */
+ /* This implementation isn't efficient, but it is simple. */
+ PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
+ PL_slabs[PL_slab_count++] = PL_OpSlab;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
+#endif
}
assert( PL_OpSpace >= 0 );
/* Move the allocation pointer down */
return (void *)(PL_OpPtr + 1);
}
+#ifdef PERL_DEBUG_READONLY_OPS
+void
+Perl_pending_Slabs_to_ro(pTHX) {
+ /* Turn all the allocated op slabs read only. */
+ U32 count = PL_slab_count;
+ I32 **const slabs = PL_slabs;
+
+ /* Reset the array of pending OP slabs, as we're about to turn this lot
+ read only. Also, do it ahead of the loop in case the warn triggers,
+ and a warn handler has an eval */
+
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+
+ /* Force a new slab for any further allocation. */
+ PL_OpSpace = 0;
+
+ while (count--) {
+ void *const start = slabs[count];
+ const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
+ if(mprotect(start, size, PROT_READ)) {
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
+ start, (unsigned long) size, errno);
+ }
+ }
+
+ free(slabs);
+}
+
+STATIC void
+S_Slab_to_rw(pTHX_ void *op)
+{
+ 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 );
+ if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
+ slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
+ }
+}
+
+OP *
+Perl_op_refcnt_inc(pTHX_ OP *o)
+{
+ if(o) {
+ Slab_to_rw(o);
+ ++o->op_targ;
+ }
+ return o;
+
+}
+
+PADOFFSET
+Perl_op_refcnt_dec(pTHX_ OP *o)
+{
+ Slab_to_rw(o);
+ return --o->op_targ;
+}
+#else
+# define Slab_to_rw(op)
+#endif
+
void
Perl_Slab_Free(pTHX_ void *op)
{
assert( ptr-1 > (I32 **) slab );
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
+ Slab_to_rw(op);
if (--(*slab) == 0) {
# ifdef NETWARE
# define PerlMemShared PerlMem
# endif
+#ifdef PERL_DEBUG_READONLY_OPS
+ U32 count = PL_slab_count;
+ /* Need to remove this slab from our list of slabs */
+ if (count) {
+ while (count--) {
+ if (PL_slabs[count] == slab) {
+ /* Found it. Move the entry at the end to overwrite it. */
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "Deallocate %p by moving %p from %lu to %lu\n",
+ PL_OpSlab,
+ PL_slabs[PL_slab_count - 1],
+ PL_slab_count, count));
+ PL_slabs[count] = PL_slabs[--PL_slab_count];
+ /* Could realloc smaller at this point, but probably not
+ worth it. */
+ if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
+ perror("munmap failed");
+ abort();
+ }
+ break;
+ }
+ }
+ }
+#else
PerlMemShared_free(slab);
+#endif
if (slab == PL_OpSlab) {
PL_OpSpace = 0;
}
{
dVAR;
PADOFFSET off;
- const bool is_our = (PL_in_my == KEY_our);
+ const bool is_our = (PL_parser->in_my == KEY_our);
/* complain about "my $<special_var>" etc etc */
if (*name &&
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
- name[0], toCTRL(name[1]), name + 2));
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
+ name[0], toCTRL(name[1]), name + 2,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
/* check for duplicate declaration */
pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
- if (PL_in_my_stash && *name != '$') {
+ if (PL_parser->in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
name,
- is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ is_our ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
}
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
- PL_in_my_stash,
+ PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
),
0, /* not fake */
- PL_in_my == KEY_state
+ PL_parser->in_my == KEY_state
);
+ /* anon sub prototypes contains state vars should always be cloned,
+ * otherwise the state var would be shared between anon subs */
+
+ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
+ CvCLONE_on(PL_compcv);
+
return off;
}
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
-void
+static void
S_op_destroy(pTHX_ OP *o)
{
if (o->op_latefree) {
FreeOp(o);
}
+#ifdef USE_ITHREADS
+# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
+#else
+# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
+#endif
/* Destructor */
dVAR;
OPCODE type;
- if (!o || o->op_static)
+ if (!o)
return;
if (o->op_latefreed) {
if (o->op_latefree)
OP_REFCNT_LOCK;
refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
- if (refcnt)
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
return;
}
+ }
break;
default:
break;
if (type == OP_NULL)
type = (OPCODE)o->op_targ;
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(o);
+#endif
+
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
+ if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
+ }
op_clear(o);
if (o->op_latefree) {
}
break;
case OP_SUBST:
- op_free(cPMOPo->op_pmreplroot);
+ op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
goto clear_pmop;
case OP_PUSHRE:
#ifdef USE_ITHREADS
- if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
+ if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
/* No GvIN_PAD_off here, because other references may still
* exist on the pad */
- pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
+ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
- SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
+ SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
#endif
/* FALL THROUGH */
case OP_MATCH:
case OP_QR:
clear_pmop:
- {
- 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;
- }
- }
- }
- PmopSTASH_free(cPMOPo);
- }
- cPMOPo->op_pmreplroot = NULL;
+ forget_pmop(cPMOPo, 1);
+ cPMOPo->op_pmreplrootu.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
#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]);
+ SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
}
Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
+STATIC void
+S_forget_pmop(pTHX_ PMOP *const o
+#ifdef USE_ITHREADS
+ , U32 flags
+#endif
+ )
+{
+ HV * const pmstash = PmopSTASH(o);
+ if (pmstash && !SvIS_FREED(pmstash)) {
+ MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP **const array = (PMOP**) mg->mg_ptr;
+ U32 count = mg->mg_len / sizeof(PMOP**);
+ U32 i = count;
+
+ while (i--) {
+ if (array[i] == o) {
+ /* Found it. Move the entry at the end to overwrite it. */
+ array[i] = array[--count];
+ mg->mg_len = count * sizeof(PMOP**);
+ /* Could realloc smaller at this point always, but probably
+ not worth it. Probably worth free()ing if we're the
+ last. */
+ if(!count) {
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ }
+ break;
+ }
+ }
+ }
+ }
+ if (PL_curpm == o)
+ PL_curpm = NULL;
+#ifdef USE_ITHREADS
+ if (flags)
+ PmopSTASH_free(o);
+#endif
+}
+
+STATIC void
+S_find_and_forget_pmops(pTHX_ OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ while (kid) {
+ switch (kid->op_type) {
+ case OP_SUBST:
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_QR:
+ forget_pmop((PMOP*)kid, 0);
+ }
+ find_and_forget_pmops(kid);
+ kid = kid->op_sibling;
+ }
+ }
+}
+
void
Perl_op_null(pTHX_ OP *o)
{
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
OP *kid;
/* assumes no premature commitment */
- if (!o || PL_error_count || (o->op_flags & OPf_WANT)
+ if (!o || (PL_parser && PL_parser->error_count)
+ || (o->op_flags & OPf_WANT)
|| o->op_type == OP_RETURN)
{
return o;
break;
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplroot)
+ if (!kPMOP->op_pmreplrootu.op_pmreplroot)
deprecate_old("implicit split to @_");
}
/* FALL THROUGH */
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR) || PL_error_count
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN)
{
return o;
return scalar(o);
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplroot)
+ if (!kPMOP->op_pmreplrootu.op_pmreplroot)
deprecate_old("implicit split to @_");
}
break;
OP *kid;
/* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ if (!o || (o->op_flags & OPf_WANT)
+ || (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN)
{
return o;
/* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
int localize = -1;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
if ((o->op_private & OPpTARGET_MY)
Perl_croak(aTHX_ "That use of $[ is unsupported");
break;
case OP_STUB:
- if (o->op_flags & OPf_PARENS || PL_madskills)
+ if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
case OP_RECV:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
return TRUE;
default:
return FALSE;
dVAR;
OP *kid;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
switch (o->op_type) {
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
- SAVEINT(PL_expect);
stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
dVAR;
I32 type;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
type = o->op_type;
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" : PL_in_my == KEY_state ? "state" : "my"));
+ PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
/* check for C<my Dog $spot> when deciding package */
stash = PAD_COMPNAME_TYPE(o->op_targ);
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
- if (PL_in_my == KEY_state)
+ if (PL_parser->in_my == KEY_state)
o->op_private |= OPpPAD_STATE;
return o;
}
else
o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
}
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
return o;
}
NOOP;
#endif
else {
- if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+ if ( PL_parser->bufptr > PL_parser->oldbufptr
+ && PL_parser->bufptr[-1] == ','
&& ckWARN(WARN_PARENTHESIS))
{
- char *s = PL_bufptr;
+ char *s = PL_parser->bufptr;
bool sigil = FALSE;
/* some heuristics to detect a potential error */
if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
- : "local");
+ lex
+ ? (PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state
+ ? "state"
+ : "my")
+ : "local");
}
}
}
o = my(o);
else
o = mod(o, OP_NULL); /* a bit kludgey */
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
return o;
}
goto nope;
}
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
const I32 oldtmps_floor = PL_tmps_floor;
list(o);
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
PL_op = curop = LINKLIST(o);
}
MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
{
MADPROP *mp;
Newxz(mp, 1, MADPROP);
return;
if (mp->mad_next)
mad_free(mp->mad_next);
-/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
+/* if (PL_parser && PL_parser->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:
pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_hints & HINT_RE_TAINT)
- pmop->op_pmpermflags |= PMf_RETAINT;
+ pmop->op_pmflags |= PMf_RETAINT;
if (PL_hints & HINT_LOCALE)
- pmop->op_pmpermflags |= PMf_LOCALE;
- pmop->op_pmflags = pmop->op_pmpermflags;
+ pmop->op_pmflags |= PMf_LOCALE;
+
#ifdef USE_ITHREADS
if (av_len((AV*) PL_regex_pad[0]) > -1) {
}
#endif
- /* link into pm list */
- if (type != OP_TRANS && PL_curstash) {
- 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);
}
pm = (PMOP*)o;
if (expr->op_type == OP_CONST) {
- STRLEN plen;
SV * const pat = ((SVOP*)expr)->op_sv;
- const char *p = SvPV_const(pat, plen);
- if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
- U32 was_readonly = SvREADONLY(pat);
+ U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
- if (was_readonly) {
- if (SvFAKE(pat)) {
- sv_force_normal_flags(pat, 0);
- assert(!SvREADONLY(pat));
- was_readonly = 0;
- } else {
- SvREADONLY_off(pat);
- }
- }
+ if (o->op_flags & OPf_SPECIAL)
+ pm_flags |= RXf_SPLIT;
- sv_setpvn(pat, "\\s+", 3);
+ if (DO_UTF8(pat))
+ pm_flags |= RXf_UTF8;
- SvFLAGS(pat) |= was_readonly;
+ PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
- p = SvPV_const(pat, plen);
- pm->op_pmflags |= PMf_SKIPWHITE;
- }
- if (DO_UTF8(pat))
- pm->op_pmdynflags |= PMdf_UTF8;
- /* FIXME - can we make this function take const char * args? */
- PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
- if (PM_GETRE(pm)->extflags & RXf_WHITE)
- pm->op_pmflags |= PMf_WHITE;
- else
- pm->op_pmflags &= ~PMf_WHITE;
#ifdef PERL_MAD
op_getmad(expr,(OP*)pm,'e');
#else
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
curop = NULL;
- if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
- CopLINE_set(PL_curcop, (line_t)PL_multi_end);
+ if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
+ CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
}
else if (repl->op_type == OP_CONST)
curop = repl;
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
+ || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
- pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
pm->op_pmflags |= PMf_MAYBE_CONST;
- pm->op_pmpermflags |= PMf_MAYBE_CONST;
}
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_next = LINKLIST(repl);
repl->op_next = (OP*)rcop;
- pm->op_pmreplroot = scalar((OP*)rcop);
- pm->op_pmreplstart = LINKLIST(rcop);
+ pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
+ assert(!(pm->op_pmflags & PMf_ONCE));
+ pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
rcop->op_next = 0;
}
}
save_item(PL_curstname);
PL_curstash = gv_stashsv(sv, GV_ADD);
+
sv_setsv(PL_curstname, sv);
PL_hints |= HINT_BLOCK_SCOPE;
- PL_copline = NOLINE;
- PL_expect = XSTATE;
+ PL_parser->copline = NOLINE;
+ PL_parser->expect = XSTATE;
#ifndef PERL_MAD
op_free(o);
*/
PL_hints |= HINT_BLOCK_SCOPE;
- PL_copline = NOLINE;
- PL_expect = XSTATE;
+ PL_parser->copline = NOLINE;
+ PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
#ifdef PERL_MAD
sv = va_arg(*args, SV*);
}
}
- {
- 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);
- PL_expect = oexpect;
- PL_copline = ocopline;
- PL_curcop = ocurcop;
- }
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work. */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, FALSE);
+ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ veop, modname, imop);
+ LEAVE;
}
OP *
}
if (is_list_assignment(left)) {
+ static const char no_list_state[] = "Initialization of state variables"
+ " in list context currently forbidden";
OP *curop;
PL_modcount = 0;
/* Grandfathering $[ assignment here. Bletch.*/
/* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
+ PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = mod(left, OP_AASSIGN);
if (PL_eval_start)
PL_eval_start = 0;
break;
}
else if (curop->op_type == OP_PUSHRE) {
- if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
- ((PMOP*)curop)->op_pmreplroot));
-#else
- GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
-#endif
+ if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
+ GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
break;
GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#else
+ GV *const gv
+ = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+ if (gv) {
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ break;
GvASSIGN_GENERATION_set(gv, PL_generation);
}
+#endif
}
else
break;
o->op_private |= OPpASSIGN_COMMON;
}
- if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
- && (left->op_type == OP_LIST
- || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
- {
+ if ((left->op_type == OP_LIST
+ || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
OP* lop = ((LISTOP*)left)->op_first;
while (lop) {
if (lop->op_type == OP_PADSV ||
lop->op_type == OP_PADAV ||
lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY)
- {
+ lop->op_type == OP_PADANY) {
if (lop->op_private & OPpPAD_STATE) {
if (left->op_private & OPpLVAL_INTRO) {
- o->op_private |= OPpASSIGN_STATE;
- /* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(lop->op_targ));
+ /* Each variable in state($a, $b, $c) = ... */
}
- else { /* we already checked for WARN_MISC before */
- Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
- PAD_COMPNAME_PV(lop->op_targ));
+ else {
+ /* Each state variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
}
+ yyerror(no_list_state);
+ } else {
+ /* Each my variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
}
+ } else {
+ /* Other ops in the list. undef may be interesting in
+ (state $a, undef, state $c) */
}
lop = lop->op_sibling;
}
}
-
- if (right && right->op_type == OP_SPLIT) {
+ else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
+ == (OPpLVAL_INTRO | OPpPAD_STATE))
+ && ( left->op_type == OP_PADSV
+ || left->op_type == OP_PADAV
+ || left->op_type == OP_PADHV
+ || left->op_type == OP_PADANY))
+ {
+ /* All single variable list context state assignments, hence
+ state ($a) = ...
+ (state $a) = ...
+ state @a = ...
+ state (@a) = ...
+ (state @a) = ...
+ state %a = ...
+ state (%a) = ...
+ (state %a) = ...
+ */
+ yyerror(no_list_state);
+ }
+
+ if (right && right->op_type == OP_SPLIT && !PL_madskills) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
!(o->op_private & OPpASSIGN_COMMON) )
{
tmpop = ((UNOP*)left)->op_first;
- if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
+ if (tmpop->op_type == OP_GV
#ifdef USE_ITHREADS
- pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
+ && !pm->op_pmreplrootu.op_pmtargetoff
+#else
+ && !pm->op_pmreplrootu.op_pmtargetgv
+#endif
+ ) {
+#ifdef USE_ITHREADS
+ pm->op_pmreplrootu.op_pmtargetoff
+ = cPADOPx(tmpop)->op_padix;
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
+ pm->op_pmreplrootu.op_pmtargetgv
+ = (GV*)cSVOPx(tmpop)->op_sv;
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
pm->op_pmflags |= PMf_ONCE;
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
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;
HINTS_REFCNT_UNLOCK;
}
- if (PL_copline == NOLINE)
+ if (PL_parser && PL_parser->copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
else {
- CopLINE_set(cop, PL_copline);
- PL_copline = NOLINE;
+ CopLINE_set(cop, PL_parser->copline);
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
}
#ifdef USE_ITHREADS
CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
/* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
if (first->op_type == OP_NOT
&& (first->op_flags & OPf_SPECIAL)
- && (first->op_flags & OPf_KIDS)) {
+ && (first->op_flags & OPf_KIDS)
+ && !PL_madskills) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
if (o->op_next)
first->op_next = o->op_next;
cUNOPo->op_first = NULL;
-#ifdef PERL_MAD
- op_getmad(o,first,'O');
-#else
op_free(o);
-#endif
}
}
if (first->op_type == OP_CONST) {
if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
|| o2->op_type == OP_PADHV)
&& o2->op_private & OPpLVAL_INTRO
+ && !(o2->op_private & OPpPAD_STATE)
&& ckWARN(WARN_DEPRECATED))
{
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
}
if (warnop) {
const line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
PL_op_desc[warnop],
redo = LINKLIST(listop);
if (expr) {
- PL_copline = (line_t)whileline;
+ PL_parser->copline = (line_t)whileline;
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
if (madsv)
op_getmad(madsv, (OP*)loop, 'v');
- PL_copline = forline;
+ PL_parser->copline = forline;
return newSTATEOP(0, label, wop);
}
o = newOP(type, OPf_SPECIAL);
else {
o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
- ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
+ ? SvPV_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
#ifdef PERL_MAD
op_other if the match fails.)
*/
-STATIC
-OP *
+STATIC OP *
S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
I32 enter_opcode, I32 leave_opcode,
PADOFFSET entertarg)
[*] possibly surprising
*/
-STATIC
-bool
+STATIC bool
S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
looks_like_bool(cLOGOPo->op_first)
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
+ case OP_NULL:
+ return (
+ o->op_flags & OPf_KIDS
+ && looks_like_bool(cUNOPo->op_first));
+
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
Perl_cv_undef(pTHX_ CV *cv)
{
dVAR;
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(PL_comppad))
+ );
+
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvISXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
dVAR;
SV *sv = NULL;
+ if (PL_madskills)
+ return NULL;
+
if (!o)
return NULL;
= (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;
+ const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
if (proto) {
assert(proto->op_type == OP_CONST);
- ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
}
else
ps = NULL;
sv_setpvn((SV*)gv, ps, ps_len);
else
sv_setiv((SV*)gv, -1);
+
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
- PL_sub_generation++;
goto done;
}
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
{
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined", name);
GvCV(gv) = NULL;
cv = newCONSTSUB(NULL, name, const_sv);
}
- PL_sub_generation++;
+ mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+ (CvGV(cv) && GvSTASH(CvGV(cv)))
+ ? GvSTASH(CvGV(cv))
+ : CvSTASH(cv)
+ ? CvSTASH(cv)
+ : PL_curstash
+ );
if (PL_madskills)
goto install_block;
op_free(block);
}
}
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
}
}
CvGV(cv) = gv;
if (ps)
sv_setpvn((SV*)cv, ps, ps_len);
- if (PL_error_count) {
+ if (PL_parser && PL_parser->error_count) {
op_free(block);
block = NULL;
if (name) {
CopFILE(PL_curcop),
(long)PL_subline, (long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
- hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
}
}
- if (name && !PL_error_count)
+ if (name && ! (PL_parser && PL_parser->error_count))
process_special_blocks(name, gv, cv);
}
done:
- PL_copline = NOLINE;
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
return cv;
}
ENTER;
+ if (IN_PERL_RUNTIME) {
+ /* at runtime, it's not safe to manipulate PL_curcop: it may be
+ * an op shared between threads. Use a non-shared COP for our
+ * dirty work */
+ SAVEVPTR(PL_curcop);
+ PL_curcop = &PL_compiling;
+ }
SAVECOPLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
+ CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
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);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined"
if (name) {
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
CvGV(cv) = gv;
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
: "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
#else
op_free(o);
#endif
- PL_copline = NOLINE;
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
#ifdef PERL_MAD
return pegop;
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)
+ if (kid->op_type != OP_RV2CV
+ && !(PL_parser && PL_parser->error_count))
Perl_croak(aTHX_ "%s argument is not a subroutine name",
OP_DESC(o));
o->op_private |= OPpEXISTS_SUB;
PADOFFSET offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
- /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
+ /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
OP* k;
else
scalar(kid);
o = ck_fun(o);
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
}
OP *
+Perl_ck_readline(pTHX_ OP *o)
+{
+ if (!(o->op_flags & OPf_KIDS)) {
+ OP * const newop
+ = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
+ op_free(o);
+#endif
+ return newop;
+ }
+ return o;
+}
+
+OP *
Perl_ck_rfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
+ dVAR;
OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Cannot steal the second time! */
- && !(kid->op_private & OPpTARGET_MY))
+ && !(kid->op_private & OPpTARGET_MY)
+ /* Keep the full thing for madskills */
+ && !PL_madskills
+ )
{
OP * const kkid = kid->op_sibling;
/* 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;
}
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;
+ const PADOFFSET target = kkid->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ kkid->op_flags
+ | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const condop = first->op_next;
/* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+ SvPADSTALE_on(PAD_SVl(target));
+
+ condop->op_type = OP_ONCE;
+ condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ condop->op_targ = target;
+ other->op_targ = target;
+
+ /* Because we change the type of the op here, we will skip the
+ assinment binop->op_last = binop->op_first->op_sibling; at the
+ end of Perl_newBINOP(). So need to do it here. */
+ cBINOPo->op_last = cBINOPo->op_first->op_sibling;
+
+ return nullop;
}
}
return o;
}
if (o->op_type == OP_BACKTICK) {
if (!(o->op_flags & OPf_KIDS)) {
+ OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
op_free(o);
- return newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+#endif
+ return newop;
}
return o;
}
SV * const sv = kid->op_sv;
U32 was_readonly = SvREADONLY(sv);
char *s;
+ STRLEN len;
+ const char *end;
if (was_readonly) {
if (SvFAKE(sv)) {
}
}
- for (s = SvPVX(sv); *s; s++) {
+ s = SvPVX(sv);
+ len = SvCUR(sv);
+ end = s + len;
+ for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
- const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, len, char);
- SvCUR_set(sv, SvCUR(sv) - 1);
+ Move(s+2, s+1, end - s - 1, char);
+ --end;
}
}
+ SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
SvFLAGS(sv) |= was_readonly;
}
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? re->precomp : "STRING";
- const STRLEN len = re ? re->prelen : 6;
+ const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
+ const STRLEN len = re ? RX_PRELEN(re) : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%.*s/ should probably be written as \"%.*s\"",
(int)len, pmstr, (int)len, pmstr);
proto = SvPV((SV*)cv, len);
proto_end = proto + len;
}
- if (CvASSERTION(cv)) {
- U32 asserthints = 0;
- HV *const hinthv = GvHV(PL_hintgv);
- if (hinthv) {
- SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
- if (svp && *svp)
- asserthints = SvUV(*svp);
- }
- if (asserthints & HINT_ASSERTING) {
- if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
- o->op_private |= OPpENTERSUB_DB;
- }
- else {
- delete_op = 1;
- if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
- Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
- "Impossible to activate assertion call");
- }
- }
- }
}
}
}
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
OP* o3;
+ if (PL_madskills && o2->op_type == OP_STUB) {
+ o2 = o2->op_sibling;
+ continue;
+ }
if (PL_madskills && o2->op_type == OP_NULL)
o3 = ((UNOP*)o2)->op_first;
else
return o;
}
+OP *
+Perl_ck_each(pTHX_ OP *o)
+{
+
+ OP *kid = cLISTOPo->op_first;
+
+ if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+ const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+ : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+ o->op_type = new_type;
+ o->op_ppaddr = PL_ppaddr[new_type];
+ }
+ else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+ || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+ )) {
+ bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+ return o;
+ }
+ return ck_fun(o);
+}
+
/* 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 */
for (; o; o = o->op_next) {
if (o->op_opt)
break;
+ /* By default, this op has now been optimised. A couple of cases below
+ clear this again. */
+ o->op_opt = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
- o->op_opt = 1;
break;
case OP_CONST:
o->op_targ = ix;
}
#endif
- o->op_opt = 1;
break;
case OP_CONCAT:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
if (o->op_flags & OPf_STACKED) /* chained concats */
- goto ignore_optimization;
+ break; /* ignore_optimization */
else {
/* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
o->op_targ = o->op_next->op_targ;
}
op_null(o->op_next);
}
- ignore_optimization:
- o->op_opt = 1;
break;
case OP_STUB:
if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- o->op_opt = 1;
break; /* Scalar stub must produce undef. List stub is noop */
}
goto nothin;
has already occurred. This doesn't fix the real problem,
though (See 20010220.007). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
- if (oldop && o->op_next) {
- oldop->op_next = o->op_next;
- continue;
- }
- break;
+ o->op_opt = 0;
+ /* FALL THROUGH */
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
- nothin:
+ nothin:
if (oldop && o->op_next) {
oldop->op_next = o->op_next;
+ o->op_opt = 0;
continue;
}
- o->op_opt = 1;
break;
case OP_PADAV:
o->op_flags |= OPf_SPECIAL;
o->op_type = OP_AELEMFAST;
}
- o->op_opt = 1;
break;
}
op_null(o->op_next);
}
- o->op_opt = 1;
break;
case OP_MAPWHILE:
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
- o->op_opt = 1;
+ case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
case OP_ENTERLOOP:
case OP_ENTERITER:
- o->op_opt = 1;
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
peep(cLOOP->op_lastop);
break;
- case OP_QR:
- case OP_MATCH:
case OP_SUBST:
- o->op_opt = 1;
- while (cPMOP->op_pmreplstart &&
- cPMOP->op_pmreplstart->op_type == OP_NULL)
- cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
- peep(cPMOP->op_pmreplstart);
+ assert(!(cPMOP->op_pmflags & PMf_ONCE));
+ while (cPMOP->op_pmstashstartu.op_pmreplstart &&
+ cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
+ cPMOP->op_pmstashstartu.op_pmreplstart
+ = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
+ peep(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
case OP_EXEC:
- o->op_opt = 1;
if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
&& ckWARN(WARN_SYNTAX))
{
const char *key = NULL;
STRLEN keylen;
- o->op_opt = 1;
-
if (((BINOP*)o)->op_last->op_type != OP_CONST)
break;
/* make @a = sort @a act in-place */
- o->op_opt = 1;
-
oright = cUNOPx(oright)->op_sibling;
if (!oright)
break;
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
LISTOP *enter, *exlist;
- o->op_opt = 1;
enter = (LISTOP *) o->op_next;
if (!enter)
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)
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
}
- default:
- o->op_opt = 1;
+ case OP_QR:
+ case OP_MATCH:
+ if (!(cPMOP->op_pmflags & PMf_ONCE)) {
+ assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
+ }
break;
}
oldop = o;
LEAVE;
}
-char*
+const char*
Perl_custom_op_name(pTHX_ const OP* o)
{
dVAR;
return SvPV_nolen(HeVAL(he));
}
-char*
+const char*
Perl_custom_op_desc(pTHX_ const OP* o)
{
dVAR;
https://perl5.git.perl.org / perl5.git / blobdiff