/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
#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 */
+
+ free(PL_slabs);
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+
+ /* Force a new slab for any further allocation. */
+ PL_OpSpace = 0;
+
+ while (count--) {
+ const void *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);
+ }
+ }
+}
+
+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);
+ }
+}
+#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. */
+ goto gotcha;
+ }
+
+ }
+ Perl_croak(aTHX_
+ "panic: Couldn't find slab at %p (%lu allocated)",
+ slab, (unsigned long) PL_slabs);
+ gotcha:
+ if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
+ perror("munmap failed");
+ abort();
+ }
+ }
+#else
PerlMemShared_free(slab);
+#endif
if (slab == PL_OpSlab) {
PL_OpSpace = 0;
}
return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
- (void*)cSVOPo_sv));
+ SVfARG(cSVOPo_sv)));
}
/* "register" allocation */
return off;
}
+/* free the body of an op without examining its contents.
+ * Always use this rather than FreeOp directly */
+
+static void
+S_op_destroy(pTHX_ OP *o)
+{
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ FreeOp(o);
+}
+
+
/* Destructor */
void
if (!o || o->op_static)
return;
+ if (o->op_latefreed) {
+ if (o->op_latefree)
+ return;
+ goto do_free;
+ }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
case OP_LEAVEWRITE:
{
PADOFFSET refcnt;
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(o);
+#endif
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;
/* 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) {
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(o);
+#endif
cop_free((COP*)o);
+ }
op_clear(o);
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
/* FALL THROUGH */
case OP_TRANS:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+#ifdef USE_ITHREADS
+ if (cPADOPo->op_padix > 0) {
+ pad_swipe(cPADOPo->op_padix, TRUE);
+ cPADOPo->op_padix = 0;
+ }
+#else
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
+#endif
}
else {
- Safefree(cPVOPo->op_pv);
+ PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
}
break;
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);
- }
+ forget_pmop(cPMOPo, 1);
cPMOPo->op_pmreplroot = NULL;
/* we use the "SAFE" version of the PM_ macros here
* since sv_clean_all might release some PMOPs
#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);
}
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopLABEL_free(cop);
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
+STATIC void
+S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
+{
+ 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 (flags)
+ PmopSTASH_free(o);
+}
+
+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)
{
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SORT:
if (ckWARN(WARN_VOID))
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
}
break;
- case OP_THREADSV:
- o->op_flags |= OPf_MOD; /* XXX ??? */
- break;
-
case OP_RV2AV:
case OP_RV2HV:
if (set_op_ref)
type == OP_RV2AV ||
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",
+ 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"));
} else if (attrs) {
{
const char * const desc
= PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
- ? rtype : OP_MATCH];
+ ? (int)rtype : OP_MATCH];
const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
if (o->op_type == OP_STUB) {
PL_comppad_name = 0;
PL_compcv = 0;
- FreeOp(o);
+ S_op_destroy(aTHX_ o);
return;
}
PL_main_root = scope(sawparens(scalarvoid(o)));
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv = get_cv("DB::postponed", FALSE);
+ CV * const cv
+ = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
if (cv) {
dSP;
PUSHMARK(SP);
dVAR;
register OP *curop;
OP *newop;
- I32 type = o->op_type;
- SV *sv = NULL;
+ VOL I32 type = o->op_type;
+ SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
OP *old_next;
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, (GV*)sv);
else
- newop = newSVOP(OP_CONST, 0, sv);
+ newop = newSVOP(OP_CONST, 0, (SV*)sv);
op_getmad(o,newop,'f');
return newop;
pp_pushmark();
CALLRUNOPS(aTHX);
PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
pp_anonlist();
PL_tmps_floor = oldtmps_floor;
last->op_madprop = 0;
#endif
- FreeOp(last);
+ S_op_destroy(aTHX_ (OP*)last);
return (OP*)first;
}
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
+ o->op_latefree = 0;
+ o->op_latefreed = 0;
+ o->op_attached = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
- SV * const rstr = ((SVOP*)repl)->op_sv;
+ SV * const rstr =
+#ifdef PERL_MAD
+ (repl->op_type == OP_NULL)
+ ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
+#endif
+ ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
I32 del = o->op_private & OPpTRANS_DELETE;
+ SV* swash;
PL_hints |= HINT_BLOCK_SCOPE;
if (SvUTF8(tstr))
else
bits = 8;
- Safefree(cPVOPo->op_pv);
- cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
+ PerlMemShared_free(cPVOPo->op_pv);
+ cPVOPo->op_pv = NULL;
+
+ swash = (SV*)swash_init("utf8", "", listsv, bits, none);
+#ifdef USE_ITHREADS
+ cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
+ SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
+ PAD_SETSV(cPADOPo->op_padix, swash);
+ SvPADTMP_on(swash);
+#else
+ cSVOPo->op_sv = swash;
+#endif
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
if (!del && havefinal && rlen)
- (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
+ (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
newSVuv((UV)final), 0);
if (grows)
}
else if (j >= (I32)rlen)
j = rlen - 1;
- else
- cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
+ else {
+ tbl =
+ (short *)
+ PerlMemShared_realloc(tbl,
+ (0x101+rlen-j) * sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
+ }
tbl[0x100] = (short)(rlen - j);
for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
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);
}
STRLEN plen;
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 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
U32 was_readonly = SvREADONLY(pat);
if (was_readonly) {
SvFLAGS(pat) |= was_readonly;
p = SvPV_const(pat, plen);
- pm->op_pmflags |= PMf_SKIPWHITE;
+ pm_flags |= RXf_SKIPWHITE;
}
if (DO_UTF8(pat))
- pm->op_pmdynflags |= PMdf_UTF8;
+ pm_flags |= RXf_UTF8;
/* 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;
+ PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
+
#ifdef PERL_MAD
op_getmad(expr,(OP*)pm,'e');
#else
else {
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_SCOPE
+ || curop->op_type == OP_LEAVE
+ || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
if (curop->op_type == OP_GV) {
GV * const gv = cGVOPx_gv(curop);
repl_has_vars = 1;
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY) {
+ curop->op_type == OP_PADANY)
+ {
repl_has_vars = 1;
}
else if (curop->op_type == OP_PUSHRE)
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
+ || PM_GETRE(pm)->extflags & 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;
repl->op_next = (OP*)rcop;
pm->op_pmreplroot = scalar((OP*)rcop);
- pm->op_pmreplstart = LINKLIST(rcop);
+ assert(!(pm->op_pmflags & PMf_ONCE));
+ pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
rcop->op_next = 0;
}
}
return CHECKOP(type, svop);
}
+#ifdef USE_ITHREADS
OP *
Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
{
padop->op_padix = pad_alloc(type, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
- if (sv)
- SvPADTMP_on(sv);
+ assert(sv);
+ SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
padop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
padop->op_targ = pad_alloc(type, SVs_PADTMP);
return CHECKOP(type, padop);
}
+#endif
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
dVAR;
+ assert(gv);
#ifdef USE_ITHREADS
- if (gv)
- GvIN_PAD_on(gv);
- return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
+ GvIN_PAD_on(gv);
+ return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#else
- return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
+ return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#endif
}
Perl_package(pTHX_ OP *o)
{
dVAR;
- const char *name;
- STRLEN len;
+ SV *const sv = cSVOPo->op_sv;
#ifdef PERL_MAD
OP *pegop;
#endif
save_hptr(&PL_curstash);
save_item(PL_curstname);
- name = SvPV_const(cSVOPo->op_sv, len);
- PL_curstash = gv_stashpvn(name, len, TRUE);
- sv_setpvn(PL_curstname, name, len);
+ PL_curstash = gv_stashsv(sv, GV_ADD);
+ sv_setsv(PL_curstname, sv);
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
* that value, we know we've got commonality. We could use a
* single bit marker, but then we'd have to make 2 passes, first
* to clear the flag, then to test and set it. To find somewhere
- * to store these values, evil chicanery is done with SvCUR().
+ * to store these values, evil chicanery is done with SvUVX().
*/
- if (!(left->op_private & OPpLVAL_INTRO)) {
+ {
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
if (curop != o)
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)))
+ {
+ 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)
+ {
+ 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));
+ }
+ 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));
+ }
+ }
+ }
+ lop = lop->op_sibling;
+ }
+ }
+ 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))
+ {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(left->op_targ));
+ }
+
if (right && right->op_type == OP_SPLIT) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
cop->op_next = (OP*)cop;
if (label) {
- cop->cop_label = label;
+ CopLABEL_set(cop, label);
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- 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));
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
+ SvIV_set(*svp, PTR2IV(cop));
+ }
}
}
scalarboolean(first);
if (first->op_type == OP_CONST) {
+ /* Left or right arm of the conditional? */
+ const bool left = SvTRUE(((SVOP*)first)->op_sv);
+ OP *live = left ? trueop : falseop;
+ OP *const dead = left ? falseop : trueop;
if (first->op_private & OPpCONST_BARE &&
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
+ if (PL_madskills) {
+ /* This is all dead code when PERL_MAD is not defined. */
+ live = newUNOP(OP_NULL, 0, live);
+ op_getmad(first, live, 'C');
+ op_getmad(dead, live, left ? 'e' : 't');
+ } else {
op_free(first);
- op_free(trueop);
-#endif
- return falseop;
+ op_free(dead);
}
+ return live;
}
NewOp(1101, logop, 1, LOGOP);
logop->op_type = OP_COND_EXPR;
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)
+
+ /* The op_type check is needed to prevent a possible segfault
+ * if the loop variable is undeclared and 'strict vars' is in
+ * effect. This is illegal but is nonetheless parsed, so we
+ * may reach this point with an OP_CONST where we're expecting
+ * an OP_GV.
+ */
+ if (cUNOPx(sv)->op_first->op_type == OP_GV
+ && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
iterpflags |= OPpITER_DEF;
}
else if (sv->op_type == OP_PADSV) { /* private variable */
}
sv = NULL;
}
- else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
- padoff = sv->op_targ;
- 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;
+ if (padoff) {
+ SV *const namesv = PAD_COMPNAME_SV(padoff);
+ STRLEN len;
+ const char *const name = SvPV_const(namesv, len);
+
+ if (len == 2 && name[0] == '$' && name[1] == '_')
+ iterpflags |= OPpITER_DEF;
+ }
}
else {
const PADOFFSET offset = pad_findmy("$_");
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
- FreeOp(loop);
+ S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
#else
- loop = PerlMemShared_realloc(loop, sizeof(LOOP));
+ 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);
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
- o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
+ o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
? SvPVx_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
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;
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
- CvFILE(cv) = 0;
+ CvFILE(cv) = NULL;
#endif
if (!CvISXSUB(cv) && CvROOT(cv)) {
if (gv)
gv_efullname3(name = sv_newmortal(), gv, NULL);
- sv_setpv(msg, "Prototype mismatch:");
+ sv_setpvs(msg, "Prototype mismatch:");
if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
}
}
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
+ Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
}
}
}
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
+ block->op_attached = 1;
}
else {
/* This makes sub {}; work as expected. */
#endif
block = newblock;
}
+ else
+ block->op_attached = 1;
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
CvROOT(cv)->op_private |= OPpREFCOUNTED;
}
if (name || aname) {
- const char *s;
- const char * const tname = (name ? name : aname);
-
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
}
}
- if ((s = strrchr(tname,':')))
- s++;
- else
- s = tname;
+ if (name && !PL_error_count)
+ process_special_blocks(name, gv, cv);
+ }
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
- goto done;
+ done:
+ PL_copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ return cv;
+}
+
+STATIC void
+S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+ CV *const cv)
+{
+ const char *const colon = strrchr(fullname,':');
+ const char *const name = colon ? colon + 1 : fullname;
- if (strEQ(s, "BEGIN") && !PL_error_count) {
+ if (*name == 'B') {
+ if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
- if (!PL_beginav)
- PL_beginav = newAV();
DEBUG_x( dump_sub(gv) );
- av_push(PL_beginav, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
call_list(oldscope, PL_beginav);
CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
- else if (strEQ(s, "END") && !PL_error_count) {
- if (!PL_endav)
- PL_endav = newAV();
- DEBUG_x( dump_sub(gv) );
- av_unshift(PL_endav, 1);
- av_store(PL_endav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK") && !PL_error_count) {
- if (!PL_checkav)
- PL_checkav = newAV();
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- av_unshift(PL_checkav, 1);
- av_store(PL_checkav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT") && !PL_error_count) {
- if (!PL_initav)
- PL_initav = newAV();
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- av_push(PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
+ else
+ return;
+ } else {
+ if (*name == 'E') {
+ if strEQ(name, "END") {
+ DEBUG_x( dump_sub(gv) );
+ Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
+ } else
+ return;
+ } else if (*name == 'U') {
+ if (strEQ(name, "UNITCHECK")) {
+ /* It's never too late to run a unitcheck block */
+ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
+ }
+ else
+ return;
+ } else if (*name == 'C') {
+ if (strEQ(name, "CHECK")) {
+ if (PL_main_start && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run CHECK block");
+ Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
+ }
+ else
+ return;
+ } else if (*name == 'I') {
+ if (strEQ(name, "INIT")) {
+ if (PL_main_start && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run INIT block");
+ Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
+ }
+ else
+ return;
+ } else
+ return;
+ DEBUG_x( dump_sub(gv) );
+ GvCV(gv) = 0; /* cv has been hijacked */
}
-
- done:
- PL_copline = NOLINE;
- LEAVE_SCOPE(floor);
- return cv;
}
-/* XXX unsafe for threads if eval_owner isn't held */
/*
=for apidoc newCONSTSUB
cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
+ Safefree(file);
#ifdef USE_ITHREADS
if (stash)
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
- cv = (CV*)newSV(0);
- sv_upgrade((SV *)cv, SVt_PVCV);
+ cv = (CV*)newSV_type(SVt_PVCV);
if (name) {
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
- if (name) {
- const char *s = strrchr(name,':');
- if (s)
- s++;
- else
- s = name;
-
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
- goto done;
-
- if (strEQ(s, "BEGIN")) {
- if (!PL_beginav)
- PL_beginav = newAV();
- av_push(PL_beginav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "END")) {
- if (!PL_endav)
- PL_endav = newAV();
- av_unshift(PL_endav, 1);
- av_store(PL_endav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK")) {
- if (!PL_checkav)
- PL_checkav = newAV();
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- av_unshift(PL_checkav, 1);
- av_store(PL_checkav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT")) {
- if (!PL_initav)
- PL_initav = newAV();
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- av_push(PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- }
+ if (name)
+ process_special_blocks(name, gv, cv);
else
CvANON_on(cv);
-done:
return cv;
}
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
+ : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+ return convert(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+ return convert(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
o->op_ppaddr = PL_ppaddr[OP_PADSV];
return o;
}
- else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
- o->op_flags |= OPpDONE_SVREF;
- return o;
- }
return newUNOP(OP_RV2SV, 0, scalar(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,
+ /* Store a copy of %^H that pp_entereval can pick up.
+ OPf_SPECIAL flags the opcode as being for this purpose,
+ so that it in turn will return a copy at every
+ eval.*/
+ OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
(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",
- (void*)kidsv, badthing);
+ SVfARG(kidsv), badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((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()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
*/
priv = OPpDEREF;
if (kid->op_type == OP_PADSV) {
- name = PAD_COMPNAME_PV(kid->op_targ);
- /* SvCUR of a pad namesv can't be trusted
- * (see PL_generation), so calc its length
- * manually */
- if (name)
- len = strlen(name);
-
+ SV *const namesv
+ = PAD_COMPNAME_SV(kid->op_targ);
+ name = SvPV_const(namesv, len);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
}
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_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;
o->op_private |= OPpOPEN_OUT_CRLF;
}
}
- if (o->op_type == OP_BACKTICK)
+ 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);
+#endif
+ return newop;
+ }
return o;
+ }
{
/* In case of three-arg dup open remove strictness
* from the last arg if it is a bareword. */
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
const char *pmstr = re ? re->precomp : "STRING";
+ const STRLEN len = re ? re->prelen : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%s/ should probably be written as \"%s\"",
- pmstr, pmstr);
+ "/%.*s/ should probably be written as \"%.*s\"",
+ (int)len, pmstr, (int)len, pmstr);
}
}
return ck_fun(o);
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e = NULL;
+ const char *e = NULL;
bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
proto_end = proto + len;
}
if (CvASSERTION(cv)) {
- if (PL_hints & HINT_ASSERTING) {
+ 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 (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
+ 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
optional = 1;
proto++;
continue;
+ case '_':
+ /* _ must be at the end */
+ if (proto[1] && proto[1] != ';')
+ goto oops;
case '$':
proto++;
arg++;
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)
+ o3->op_type == OP_AELEM)
goto wrapref;
if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o3);
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), (void*)cv);
+ gv_ename(namegv), SVfARG(cv));
}
}
else
prev = o2;
o2 = o2->op_sibling;
} /* while */
+ if (o2 == cvop && proto && *proto == '_') {
+ /* generate an access to $_ */
+ o2 = newDEFSVOP();
+ o2->op_sibling = prev->op_sibling;
+ prev->op_sibling = o2; /* instead of cvop */
+ }
if (proto && !optional && proto_end > proto &&
- (*proto != '@' && *proto != '%' && *proto != ';'))
+ (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
- (void*)sv);
+ SVfARG(sv));
}
}
else if (o->op_next->op_type == OP_READLINE
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:
}
+ case OP_QR:
+ case OP_MATCH:
+ if (!(cPMOP->op_pmflags & PMf_ONCE)) {
+ assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
+ }
+ /* FALL THROUGH */
default:
o->op_opt = 1;
break;
https://perl5.git.perl.org / perl5.git / blobdiff