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",
- cSVOPo_sv));
+ (void*)cSVOPo_sv));
}
/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ char *name)
+Perl_allocmy(pTHX_ const char *const name)
{
dVAR;
PADOFFSET off;
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- /* 1999-02-27 mjd@plover.com */
- char *p;
- p = strchr(name, '\0');
- /* The next block assumes the buffer is at least 205 chars
- long. At present, it's always at least 256 chars. */
- if (p-name > 200) {
- strcpy(name+200, "...");
- p = name+199;
- }
- else {
- p[1] = '\0';
- }
- /* Move everything else down one character */
- for (; p-name > 2; p--)
- *p = *(p-1);
- name[2] = toCTRL(name[1]);
- name[1] = '^';
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
+ name[0], toCTRL(name[1]), name + 2));
+ } else {
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
/* check for duplicate declaration */
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, is_our ? "our" : "my"));
+ name,
+ is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
}
/* allocate a spare slot and store the name in that slot */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
),
- 0 /* not fake */
+ 0, /* not fake */
+ PL_in_my == KEY_state
);
return off;
}
+/* 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)
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 */
CV *cv;
OP *okid;
- if (kid->op_type == OP_PUSHMARK)
- goto skip_kids;
- if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "args: type/targ %ld:%"UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid = kLISTOP->op_first;
- skip_kids:
+ if (kid->op_type != OP_PUSHMARK) {
+ if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "args: type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
+ kid = kLISTOP->op_first;
+ }
while (kid->op_sibling)
kid = kid->op_sibling;
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
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",
- OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+ 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) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : "my"));
+ PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
+ if (PL_in_my == KEY_state)
+ o->op_private |= OPpPAD_STATE;
return o;
}
{
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)));
if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : "my")
+ lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
: "local");
}
}
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;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ PL_diehook = NULL;
JMPENV_PUSH(ret);
switch (ret) {
default:
JMPENV_POP;
/* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ /* XXX note that this croak may fail as we've already blown away
+ * the stack - eg any nested evals */
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
-
JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
if (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_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);
bits = 8;
Safefree(cPVOPo->op_pv);
+ cPVOPo->op_pv = NULL;
cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
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));
+ PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
#ifdef PERL_MAD
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);
* to store these values, evil chicanery is done with SvCUR().
*/
- 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));
+ }
}
}
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);
/* 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, name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
}
}
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, ERRSV);
+ Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
}
}
}
else
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();
/* file becomes the CvFILE. For an XS, it's supposed to be static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
- and we need it to get freed. So we cheat, and take advantage of the
- fact that the first 0 bytes of any string always look the same. */
- cv = newXS(name, const_sv_xsub, file);
+ and we need it to get freed. */
+ cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- /* prototype is "". But this gets free()d. :-) */
- sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
- /* This gives us a prototype of "", rather than the file name. */
- SvCUR_set(cv, 0);
+ Safefree(file);
#ifdef USE_ITHREADS
if (stash)
return cv;
}
+CV *
+Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
+ const char *const filename, const char *const proto,
+ U32 flags)
+{
+ CV *cv = newXS(name, subaddr, filename);
+
+ if (flags & XS_DYNAMIC_FILENAME) {
+ /* We need to "make arrangements" (ie cheat) to ensure that the
+ filename lasts as long as the PVCV we just created, but also doesn't
+ leak */
+ STRLEN filename_len = strlen(filename);
+ STRLEN proto_and_file_len = filename_len;
+ char *proto_and_file;
+ STRLEN proto_len;
+
+ if (proto) {
+ proto_len = strlen(proto);
+ proto_and_file_len += proto_len;
+
+ Newx(proto_and_file, proto_and_file_len + 1, char);
+ Copy(proto, proto_and_file, proto_len, char);
+ Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
+ } else {
+ proto_len = 0;
+ proto_and_file = savepvn(filename, filename_len);
+ }
+
+ /* This gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ SV_HAS_TRAILING_NUL);
+ if (proto) {
+ /* This gives us the correct prototype, rather than one with the
+ file name appended. */
+ SvCUR_set(cv, proto_len);
+ } else {
+ SvPOK_off(cv);
+ }
+ CvFILE(cv) = proto_and_file + proto_len;
+ } else {
+ sv_setpv((SV *)cv, proto);
+ }
+ return cv;
+}
+
/*
=for apidoc U||newXS
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
=cut
*/
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined" ,cSVOPo->op_sv);
+ : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
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 *
(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",
- kidsv, badthing);
+ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ (void*)kidsv, badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
+ OP *firstop;
OP *op = ((BINOP*)kid)->op_first;
name = NULL;
if (op) {
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op->op_type == OP_RV2HV)) &&
- (op = ((UNOP*)op)->op_first) &&
- (op->op_type == OP_GV)) {
+ (firstop = ((UNOP*)op)->op_first) &&
+ (firstop->op_type == OP_GV)) {
/* packagevar $a[] or $h{} */
- GV * const gv = cGVOPx_gv(op);
+ GV * const gv = cGVOPx_gv(firstop);
if (gv)
tmpstr =
Perl_newSVpvf(aTHX_
}
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;
return kid;
}
}
+ if (kid->op_sibling) {
+ OP *kkid = kid->op_sibling;
+ if (kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO)
+ && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+ }
+ }
return o;
}
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++;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), cv);
+ gv_ename(namegv), (void*)cv);
}
}
else
prev = o2;
o2 = o2->op_sibling;
} /* while */
+ if (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",
- sv);
+ (void*)sv);
}
}
else if (o->op_next->op_type == OP_READLINE