/* 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.
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
+ C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> 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.
+ saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
+ it will be correctly restored when any inner compiling scope is exited.
*/
#include "EXTERN.h"
#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 */
+
+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;
/* 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;
#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))
PerlMemShared_free(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io)) {
-#ifdef USE_ITHREADS
- NOOP;
-#else
- SvREFCNT_dec(cop->cop_io);
-#endif
- }
- Perl_refcounted_he_free(aTHX_ cop->cop_hints);
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
void
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),
PL_hints &= ~HINT_BLOCK_SCOPE;
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) ;
- SAVEFREESV(PL_compiling.cop_io) ;
- }
return retval;
}
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) {
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;
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;
- CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+ /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
+ CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
+ */
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) {
+ cop->cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (cop->cop_hints_hash) {
HINTS_REFCNT_LOCK;
- cop->cop_hints->refcounted_he_refcnt++;
+ cop->cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
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)
: ""));
}
/* 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));
}
(op) == OP_EQ || (op) == OP_I_EQ || \
(op) == OP_NE || (op) == OP_I_NE || \
(op) == OP_NCMP || (op) == OP_I_NCMP)
- o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ o->op_private = (U8)(PL_hints & HINT_INTEGER);
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& (o->op_type == OP_BIT_OR
|| o->op_type == OP_BIT_AND
}
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;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
SV * const rsv = SvRV(kidsv);
- const int svtype = SvTYPE(rsv);
+ const svtype type = SvTYPE(rsv);
const char *badtype = NULL;
switch (o->op_type) {
case OP_RV2SV:
- if (svtype > SVt_PVMG)
+ if (type > SVt_PVMG)
badtype = "a SCALAR";
break;
case OP_RV2AV:
- if (svtype != SVt_PVAV)
+ if (type != SVt_PVAV)
badtype = "an ARRAY";
break;
case OP_RV2HV:
- if (svtype != SVt_PVHV)
+ if (type != SVt_PVHV)
badtype = "a HASH";
break;
case OP_RV2CV:
- if (svtype != SVt_PVCV)
+ if (type != SVt_PVCV)
badtype = "a CODE";
break;
}
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
https://perl5.git.perl.org / perl5.git / blobdiff