/* 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"
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) {
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;
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];
if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_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_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
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);
* 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;
+ }
+ }
+
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));
+ }
}
}
}
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)) {
gv_efullname3(name = sv_newmortal(), gv, NULL);
sv_setpv(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;
else
s = tname;
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
+ if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
av_store(PL_endav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
+ else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
+ /* It's never too late to run a unitcheck block */
+ if (!PL_unitcheckav)
+ PL_unitcheckav = newAV();
+ DEBUG_x( dump_sub(gv) );
+ av_unshift(PL_unitcheckav, 1);
+ av_store(PL_unitcheckav, 0, (SV*)cv);
+ GvCV(gv) = 0; /* cv has been hijacked */
+ }
else if (strEQ(s, "CHECK") && !PL_error_count) {
if (!PL_checkav)
PL_checkav = newAV();
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)
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
/* 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_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;
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");
}
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
projects / p5sagit/p5-mst-13.2.git / blobdiff