/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
recursive, but it's recursive on basic blocks, not on tree nodes.
*/
+/* To implement user lexical pragmas, there needs to be a way at run time to
+ get the compile time state of %^H for that block. Storing %^H in every
+ block (or even COP) would be very expensive, so a different approach is
+ taken. The (running) state of %^H is serialised into a tree of HE-like
+ structs. Stores into %^H are chained onto the current leaf as a struct
+ refcounted_he * with the key and the value. Deletes from %^H are saved
+ with a value of PL_sv_placeholder. The state of %^H at any point can be
+ turned back into a regular HV by walking back up the tree from that point's
+ leaf, ignoring any key you've already seen (placeholder or not), storing
+ the rest into the HV structure, then removing the placeholders. Hence
+ memory is only used to store the %^H deltas from the enclosing COP, rather
+ than the entire %^H on each COP.
+
+ 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
+ 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.
+*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
void
Perl_Slab_Free(pTHX_ void *op)
{
- I32 **ptr = (I32 **) op;
- I32 *slab = ptr[-1];
+ 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 );
}
#endif
/*
- * In the following definition, the ", Nullop" is just to make the compiler
+ * In the following definition, the ", (OP*)0" is just to make the compiler
* think the expression is of the right type: croak actually does a Siglongjmp.
*/
#define CHECKOP(type,o) \
- ((PL_op_mask && PL_op_mask[type]) \
+ ((PL_op_mask && PL_op_mask[type]) \
? ( op_free((OP*)o), \
Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
- Nullop ) \
+ (OP*)0 ) \
: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
-STATIC char*
+STATIC const char*
S_gv_ename(pTHX_ GV *gv)
{
- STRLEN n_a;
- SV* tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, gv, Nullch);
- return SvPV(tmpsv,n_a);
+ SV* const tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, gv, NULL);
+ return SvPV_nolen_const(tmpsv);
}
STATIC OP *
STATIC void
S_no_bareword_allowed(pTHX_ const OP *o)
{
+ if (PL_madskills)
+ 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));
PADOFFSET
Perl_allocmy(pTHX_ char *name)
{
+ dVAR;
PADOFFSET off;
+ const bool is_our = (PL_in_my == KEY_our);
/* complain about "my $<special_var>" etc etc */
- if (!(PL_in_my == KEY_our ||
+ if (*name &&
+ !(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
+ (name[1] == '_' && (*name == '$' || name[2]))))
{
+ /* 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;
}
/* check for duplicate declaration */
- pad_check_dup(name,
- (bool)(PL_in_my == KEY_our),
- (PL_curstash ? PL_curstash : PL_defstash)
- );
+ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, PL_in_my == KEY_our ? "our" : "my"));
+ name, is_our ? "our" : "my"));
}
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
PL_in_my_stash,
- (PL_in_my == KEY_our
+ (is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
- : Nullhv
+ : NULL
),
0 /* not fake */
);
void
Perl_op_free(pTHX_ OP *o)
{
+ dVAR;
OPCODE type;
- PADOFFSET refcnt;
if (!o || o->op_static)
return;
+ type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
- switch (o->op_type) {
+ switch (type) {
case OP_LEAVESUB:
case OP_LEAVESUBLV:
case OP_LEAVEEVAL:
case OP_LEAVE:
case OP_SCOPE:
case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
OP_REFCNT_LOCK;
refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
if (refcnt)
return;
+ }
break;
default:
break;
op_free(kid);
}
}
- type = o->op_type;
if (type == OP_NULL)
type = (OPCODE)o->op_targ;
op_clear(o);
FreeOp(o);
+#ifdef DEBUG_LEAKING_SCALARS
+ if (PL_op == o)
+ PL_op = NULL;
+#endif
}
void
Perl_op_clear(pTHX_ OP *o)
{
+ dVAR;
+#ifdef PERL_MAD
+ /* if (o->op_madprop && o->op_madprop->mad_next)
+ abort(); */
+ /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
+ "modification of a read only value" for a reason I can't fathom why.
+ It's the "" stringification of $_, where $_ was set to '' in a foreach
+ loop, but it defies simplification into a small test case.
+ However, commenting them out has caused ext/List/Util/t/weak.t to fail
+ the last test. */
+ /*
+ mad_free(o->op_madprop);
+ o->op_madprop = 0;
+ */
+#endif
+
+ retry:
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
+ if (PL_madskills && o->op_targ != OP_NULL) {
+ o->op_type = o->op_targ;
+ o->op_targ = 0;
+ goto retry;
+ }
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
}
#else
SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
#endif
}
break;
case OP_METHOD_NAMED:
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
#ifdef USE_ITHREADS
/** Bug #15654
Even if op_clear does a pad_free for the target of the op,
case OP_TRANS:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
}
else {
Safefree(cPVOPo->op_pv);
- cPVOPo->op_pv = Nullch;
+ cPVOPo->op_pv = NULL;
}
break;
case OP_SUBST:
case OP_QR:
clear_pmop:
{
- HV *pmstash = PmopSTASH(cPMOPo);
- if (pmstash && SvREFCNT(pmstash)) {
- PMOP *pmop = HvPMROOT(pmstash);
- PMOP *lastpmop = NULL;
- while (pmop) {
- if (cPMOPo == pmop) {
- if (lastpmop)
- lastpmop->op_pmnext = pmop->op_pmnext;
- else
- HvPMROOT(pmstash) = pmop->op_pmnext;
- break;
+ 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;
}
- lastpmop = pmop;
- pmop = pmop->op_pmnext;
}
}
PmopSTASH_free(cPMOPo);
}
- cPMOPo->op_pmreplroot = Nullop;
+ cPMOPo->op_pmreplroot = NULL;
/* we use the "SAFE" version of the PM_ macros here
* since sv_clean_all might release some PMOPs
* after PL_regex_padav has been cleared
* happen before sv_clean_all
*/
ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
- PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
+ PM_SETRE_SAFE(cPMOPo, NULL);
#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]);
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
+ PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
-#if 0
- STRLEN len;
- char *s = SvPV(cop->cop_io,len);
- Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
-#endif
+ NOOP;
#else
SvREFCNT_dec(cop->cop_io);
#endif
}
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints);
}
void
Perl_op_null(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_NULL)
return;
- op_clear(o);
+ if (!PL_madskills)
+ op_clear(o);
o->op_targ = o->op_type;
o->op_type = OP_NULL;
o->op_ppaddr = PL_ppaddr[OP_NULL];
void
Perl_op_refcnt_lock(pTHX)
{
+ dVAR;
+ PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
}
void
Perl_op_refcnt_unlock(pTHX)
{
+ dVAR;
+ PERL_UNUSED_CONTEXT;
OP_REFCNT_UNLOCK;
}
OP *
Perl_linklist(pTHX_ OP *o)
{
+ OP *first;
if (o->op_next)
return o->op_next;
/* establish postfix order */
- if (cUNOPo->op_first) {
+ first = cUNOPo->op_first;
+ if (first) {
register OP *kid;
- o->op_next = LINKLIST(cUNOPo->op_first);
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
+ o->op_next = LINKLIST(first);
+ kid = first;
+ for (;;) {
+ if (kid->op_sibling) {
kid->op_next = LINKLIST(kid->op_sibling);
- else
+ kid = kid->op_sibling;
+ } else {
kid->op_next = o;
+ break;
+ }
}
}
else
STATIC OP *
S_scalarboolean(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
OP *
Perl_scalar(pTHX_ OP *o)
{
+ dVAR;
OP *kid;
/* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ if (!o || PL_error_count || (o->op_flags & OPf_WANT)
|| o->op_type == OP_RETURN)
{
return o;
OP *
Perl_scalarvoid(pTHX_ OP *o)
{
+ dVAR;
OP *kid;
- const char* useless = 0;
+ const char* useless = NULL;
SV* sv;
U8 want;
+ /* trailing mad null ops don't count as "there" for void processing */
+ if (PL_madskills &&
+ o->op_type != OP_NULL &&
+ o->op_sibling &&
+ o->op_sibling->op_type == OP_NULL)
+ {
+ OP *sib;
+ for (sib = o->op_sibling;
+ sib && sib->op_type == OP_NULL;
+ sib = sib->op_sibling) ;
+
+ if (!sib)
+ return o;
+ }
+
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_SETSTATE
|| o->op_type == OP_DBSTATE
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ if (o->op_private & OPpCONST_ARYBASE)
+ useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = 0;
+ useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
- useless = 0;
+ useless = NULL;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
(before the invention of POD) was based on a
built upon these three nroff macros being used in
void context. The pink camel has the details in
the script wrapman near page 319. */
- if (strnEQ(SvPVX(sv), "di", 2) ||
- strnEQ(SvPVX(sv), "ds", 2) ||
- strnEQ(SvPVX(sv), "ig", 2))
- useless = 0;
+ const char * const maybe_macro = SvPVX_const(sv);
+ if (strnEQ(maybe_macro, "di", 2) ||
+ strnEQ(maybe_macro, "ds", 2) ||
+ strnEQ(maybe_macro, "ig", 2))
+ useless = NULL;
}
}
}
o->op_ppaddr = PL_ppaddr[OP_PREDEC];
break;
+ case OP_I_POSTINC:
+ o->op_type = OP_I_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
+ break;
+
+ case OP_I_POSTDEC:
+ o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
+ break;
+
case OP_OR:
case OP_AND:
case OP_DOR:
case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
OP *
Perl_list(pTHX_ OP *o)
{
+ dVAR;
OP *kid;
/* assumes no premature commitment */
OP *
Perl_scalarseq(pTHX_ OP *o)
{
+ dVAR;
if (o) {
- if (o->op_type == OP_LINESEQ ||
- o->op_type == OP_SCOPE ||
- o->op_type == OP_LEAVE ||
- o->op_type == OP_LEAVETRY)
+ const OPCODE type = o->op_type;
+
+ if (type == OP_LINESEQ || type == OP_SCOPE ||
+ type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
return o;
}
-/* Propagate lvalue ("modifiable") context to an op and it's children.
+/* Propagate lvalue ("modifiable") context to an op and its children.
* 'type' represents the context type, roughly based on the type of op that
* would do the modifying, although local() is represented by OP_NULL.
* It's responsible for detecting things that can't be modified, flag
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
+ dVAR;
OP *kid;
/* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
int localize = -1;
PL_modcount++;
return o;
case OP_CONST:
- if (!(o->op_private & (OPpCONST_ARYBASE)))
+ if (!(o->op_private & OPpCONST_ARYBASE))
goto nomod;
+ localize = 0;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
+ CopARYBASE_set(&PL_compiling,
+ (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
PL_eval_start = 0;
}
else if (!type) {
- SAVEI32(PL_compiling.cop_arybase);
- PL_compiling.cop_arybase = 0;
+ SAVECOPARYBASE(&PL_compiling);
+ CopARYBASE_set(&PL_compiling, 0);
}
else if (type == OP_REFGEN)
goto nomod;
Perl_croak(aTHX_ "That use of $[ is unsupported");
break;
case OP_STUB:
- if (o->op_flags & OPf_PARENS)
+ if (o->op_flags & OPf_PARENS || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ /* The default is to set op_private to the number of children,
+ which for a UNOP such as RV2CV is always 1. And w're using
+ the bit for a flag in RV2CV, so we need it clear. */
+ o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
- newop->op_first = Nullop;
+ newop->op_first = NULL;
newop->op_next = (OP*)newop;
kid->op_sibling = (OP*)newop;
newop->op_private |= OPpLVAL_INTRO;
+ newop->op_private &= ~1;
break;
}
kid->op_next = okid;
}
else
- okid->op_next = Nullop;
+ okid->op_next = NULL;
okid->op_type = OP_RV2CV;
okid->op_targ = 0;
okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
okid->op_private |= OPpLVAL_INTRO;
+ okid->op_private &= ~1;
break;
}
}
STATIC bool
-S_scalar_mod_type(pTHX_ const OP *o, I32 type)
+S_scalar_mod_type(const OP *o, I32 type)
{
switch (type) {
case OP_SASSIGN:
}
STATIC bool
-S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
+S_is_handle_constructor(const OP *o, I32 numargs)
{
switch (o->op_type) {
case OP_PIPE_OP:
case OP_SOCKPAIR:
- if (argnum == 2)
+ if (numargs == 2)
return TRUE;
/* FALL THROUGH */
case OP_SYSOPEN:
case OP_SOCKET:
case OP_OPEN_DIR:
case OP_ACCEPT:
- if (argnum == 1)
+ if (numargs == 1)
return TRUE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
return FALSE;
}
}
OP *
-Perl_ref(pTHX_ OP *o, I32 type)
+Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
+ dVAR;
OP *kid;
if (!o || PL_error_count)
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
+ o->op_private &= ~1;
}
break;
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- ref(kid, type);
+ doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
/* FALL THROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
case OP_RV2AV:
case OP_RV2HV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
break;
case OP_PADAV:
case OP_PADHV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
break;
case OP_SCALAR:
case OP_NULL:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cBINOPo->op_first, type);
+ doref(cBINOPo->op_first, type, set_op_ref);
break;
case OP_AELEM:
case OP_HELEM:
- ref(cBINOPo->op_first, o->op_type);
+ doref(cBINOPo->op_first, o->op_type, set_op_ref);
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
: type == OP_RV2HV ? OPpDEREF_HV
case OP_SCOPE:
case OP_LEAVE:
+ set_op_ref = FALSE;
+ /* FALL THROUGH */
case OP_ENTER:
case OP_LIST:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cLISTOPo->op_last, type);
+ doref(cLISTOPo->op_last, type, set_op_ref);
break;
default:
break;
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- OP *rop = Nullop;
+ dVAR;
+ OP *rop;
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
* where the first kid is OP_PUSHMARK and the remaining ones
* are OP_CONST. We need to push the OP_CONST values.
*/
if (o->op_type == OP_CONST)
- rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
+ rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
+#ifdef PERL_MAD
+ else if (o->op_type == OP_NULL)
+ rop = NULL;
+#endif
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ rop = NULL;
for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
if (o->op_type == OP_CONST)
rop = append_elem(OP_LIST, rop,
newSVOP(OP_CONST, o->op_flags,
- SvREFCNT_inc(cSVOPo->op_sv)));
+ SvREFCNT_inc_NN(cSVOPo->op_sv)));
}
}
return rop;
STATIC void
S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
{
+ dVAR;
SV *stashsv;
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
SAVEINT(PL_expect);
- if (stash)
- stashsv = newSVpv(HvNAME(stash), 0);
- else
- stashsv = &PL_sv_no;
+ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
if (for_my) {
- SV **svp;
/* Don't force the C<use> if we don't need it. */
- svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
- sizeof(ATTRSMODULE_PM)-1, 0);
+ SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
- ; /* already in %INC */
+ NOOP; /* already in %INC */
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv);
+ newSVpvs(ATTRSMODULE), NULL);
}
else {
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv,
+ newSVpvs(ATTRSMODULE),
+ NULL,
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, stashsv),
prepend_elem(OP_LIST,
STATIC void
S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
{
+ dVAR;
OP *pack, *imop, *arg;
SV *meth, *stashsv;
apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
/* Need package name for method call. */
- pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
/* Build up the real arg-list. */
- if (stash)
- stashsv = newSVpv(HvNAME(stash), 0);
- else
- stashsv = &PL_sv_no;
+ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
+
arg = newOP(OP_PADSV, 0);
arg->op_targ = target->op_targ;
arg = prepend_elem(OP_LIST,
dup_attrlist(attrs)));
/* Fake up a method call to import */
- meth = newSVpvn("import", 6);
- (void)SvUPGRADE(meth, SVt_PVIV);
- (void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ meth = newSVpvs_share("import");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
const char *attrstr, STRLEN len)
{
- OP *attrs = Nullop;
+ OP *attrs = NULL;
if (!len) {
len = strlen(attrstr);
while (len) {
for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
if (len) {
- const char *sstr = attrstr;
+ const char * const sstr = attrstr;
for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
}
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv, prepend_elem(OP_LIST,
+ newSVpvs(ATTRSMODULE),
+ NULL, prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0,
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
+ dVAR;
I32 type;
if (!o || PL_error_count)
return o;
type = o->op_type;
+ if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
+ (void)my_kid(cUNOPo->op_first, attrs, imopsp);
+ return o;
+ }
+
if (type == OP_LIST) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
- } else if (type == OP_UNDEF) {
+ } else if (type == OP_UNDEF
+#ifdef PERL_MAD
+ || type == OP_STUB
+#endif
+ ) {
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
} else if (attrs) {
- GV *gv = cGVOPx_gv(cUNOPo->op_first);
+ GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
HV *stash;
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
/* check for C<my Dog $spot> when deciding package */
stash = PAD_COMPNAME_TYPE(o->op_targ);
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- OP *rops = Nullop;
+ dVAR;
+ OP *rops;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
#endif
if (attrs)
SAVEFREEOP(attrs);
+ rops = NULL;
o = my_kid(o, attrs, &rops);
if (rops) {
if (maybe_scalar && o->op_type == OP_PADSV) {
o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
}
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
OP *
Perl_my(pTHX_ OP *o)
{
- return my_attrs(o, Nullop);
+ return my_attrs(o, NULL);
}
OP *
Perl_sawparens(pTHX_ OP *o)
{
+ PERL_UNUSED_CONTEXT;
if (o)
o->op_flags |= OPf_PARENS;
return o;
{
OP *o;
bool ismatchop = 0;
+ const OPCODE ltype = left->op_type;
+ const OPCODE rtype = right->op_type;
- if (ckWARN(WARN_MISC) &&
- (left->op_type == OP_RV2AV ||
- left->op_type == OP_RV2HV ||
- left->op_type == OP_PADAV ||
- left->op_type == OP_PADHV)) {
- const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS)
- ? right->op_type : OP_MATCH];
- const char *sample = ((left->op_type == OP_RV2AV ||
- left->op_type == OP_PADAV)
- ? "@array" : "%hash");
+ if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
+ || ltype == OP_PADHV) && ckWARN(WARN_MISC))
+ {
+ const char * const desc
+ = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+ ? rtype : OP_MATCH];
+ const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ ? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
}
- if (right->op_type == OP_CONST &&
+ if (rtype == OP_CONST &&
cSVOPx(right)->op_private & OPpCONST_BARE &&
cSVOPx(right)->op_private & OPpCONST_STRICT)
{
no_bareword_allowed(right);
}
- ismatchop = right->op_type == OP_MATCH ||
- right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS;
+ ismatchop = rtype == OP_MATCH ||
+ rtype == OP_SUBST ||
+ rtype == OP_TRANS;
if (ismatchop && right->op_private & OPpTARGET_MY) {
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
+ OP *newleft;
+
right->op_flags |= OPf_STACKED;
- if (right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
+ if (rtype != OP_MATCH &&
+ ! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL))
- left = mod(left, right->op_type);
+ newleft = mod(left, rtype);
+ else
+ newleft = left;
if (right->op_type == OP_TRANS)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
else
- o = prepend_elem(right->op_type, scalar(left), right);
+ o = prepend_elem(rtype, scalar(newleft), right);
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
Perl_invert(pTHX_ OP *o)
{
if (!o)
- return o;
- /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return NULL;
return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
OP *
Perl_scope(pTHX_ OP *o)
{
+ dVAR;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
o->op_type = OP_SCOPE;
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
+
+ /* The following deals with things like 'do {1 for 1}' */
+ kid = kid->op_sibling;
+ if (kid &&
+ (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
+ op_null(kid);
+ }
}
else
- o = newLISTOP(OP_SCOPE, 0, o, Nullop);
+ o = newLISTOP(OP_SCOPE, 0, o, NULL);
}
return o;
}
-
-/* XXX kept for BINCOMPAT only */
-void
-Perl_save_hints(pTHX)
-{
- Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
-}
-
+
int
Perl_block_start(pTHX_ int full)
{
+ dVAR;
const int retval = PL_savestack_ix;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVESPTR(PL_compiling.cop_warnings);
- if (! specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
- }
+ 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) ;
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
+ dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP* retval = scalarseq(seq);
+ OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
STATIC OP *
S_newDEFSVOP(pTHX)
{
- const I32 offset = pad_findmy("$_");
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ dVAR;
+ const PADOFFSET offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
else {
- OP *o = newOP(OP_PADSV, 0);
+ OP * const o = newOP(OP_PADSV, 0);
o->op_targ = offset;
return o;
}
void
Perl_newPROG(pTHX_ OP *o)
{
+ dVAR;
if (PL_in_eval) {
if (PL_eval_root)
return;
/* Register with debugger */
if (PERLDB_INTER) {
- CV *cv = get_cv("DB::postponed", FALSE);
+ CV * const cv = get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
PUSHMARK(SP);
OP *
Perl_localize(pTHX_ OP *o, I32 lex)
{
+ dVAR;
if (o->op_flags & OPf_PARENS)
/* [perl #17376]: this appears to be premature, and results in code such as
C< our(%x); > executing in list mode rather than void mode */
#if 0
list(o);
#else
- ;
+ NOOP;
#endif
else {
- if (ckWARN(WARN_PARENTHESIS)
- && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
+ if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+ && ckWARN(WARN_PARENTHESIS))
{
char *s = PL_bufptr;
bool sigil = FALSE;
else
o = mod(o, OP_NULL); /* a bit kludgey */
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
Perl_jmaybe(pTHX_ OP *o)
{
if (o->op_type == OP_LIST) {
- OP *o2;
- o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+ OP * const o2
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
OP *
Perl_fold_constants(pTHX_ register OP *o)
{
+ dVAR;
register OP *curop;
+ OP *newop;
I32 type = o->op_type;
- SV *sv;
+ SV *sv = NULL;
+ int ret = 0;
+ I32 oldscope;
+ OP *old_next;
+ dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
/* XXX might want a ck_negate() for this */
cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
break;
- case OP_SPRINTF:
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if ((curop->op_type != OP_CONST ||
- (curop->op_private & OPpCONST_BARE)) &&
- curop->op_type != OP_LIST &&
- curop->op_type != OP_SCALAR &&
- curop->op_type != OP_NULL &&
- curop->op_type != OP_PUSHMARK)
+ const OPCODE type = curop->op_type;
+ if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
+ type != OP_LIST &&
+ type != OP_SCALAR &&
+ type != OP_NULL &&
+ type != OP_PUSHMARK)
{
goto nope;
}
}
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
PL_op = curop;
- CALLRUNOPS(aTHX);
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- (void)SvREFCNT_inc(sv);
- SvTEMP_off(sv);
+
+ oldscope = PL_scopestack_ix;
+ create_eval_scope(G_FAKINGEVAL);
+
+ JMPENV_PUSH(ret);
+
+ switch (ret) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ, FALSE);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ SvREFCNT_inc_simple_void(sv);
+ SvTEMP_off(sv);
+ }
+ break;
+ case 3:
+ /* Something tried to die. Abandon constant folding. */
+ /* Pretend the error never happened. */
+ sv_setpvn(ERRSV,"",0);
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
+
+ JMPENV_POP;
+
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
+
+ if (ret)
+ goto nope;
+
+#ifndef PERL_MAD
op_free(o);
+#endif
+ assert(sv);
if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, (GV*)sv);
- return newSVOP(OP_CONST, 0, sv);
+ newop = newGVOP(OP_GV, 0, (GV*)sv);
+ else
+ newop = newSVOP(OP_CONST, 0, sv);
+ op_getmad(o,newop,'f');
+ return newop;
- nope:
+ nope:
return o;
}
OP *
Perl_gen_constant_list(pTHX_ register OP *o)
{
+ dVAR;
register OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in peep() */
curop = ((UNOP*)o)->op_first;
- ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
+ ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
+#ifdef PERL_MAD
+ op_getmad(curop,o,'O');
+#else
op_free(curop);
+#endif
linklist(o);
return list(o);
}
OP *
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
+ dVAR;
if (!o || o->op_type != OP_LIST)
- o = newLISTOP(OP_LIST, 0, o, Nullop);
+ o = newLISTOP(OP_LIST, 0, o, NULL);
else
o->op_flags &= ~OPf_WANT;
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
+#ifdef PERL_MAD
+ if (last->op_first && first->op_madprop) {
+ MADPROP *mp = last->op_first->op_madprop;
+ if (mp) {
+ while (mp->mad_next)
+ mp = mp->mad_next;
+ mp->mad_next = first->op_madprop;
+ }
+ else {
+ last->op_first->op_madprop = first->op_madprop;
+ }
+ }
+ first->op_madprop = last->op_madprop;
+ last->op_madprop = 0;
+#endif
+
FreeOp(last);
return (OP*)first;
/* Constructors */
+#ifdef PERL_MAD
+
+TOKEN *
+Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
+{
+ TOKEN *tk;
+ Newxz(tk, 1, TOKEN);
+ tk->tk_type = (OPCODE)optype;
+ tk->tk_type = 12345;
+ tk->tk_lval = lval;
+ tk->tk_mad = madprop;
+ return tk;
+}
+
+void
+Perl_token_free(pTHX_ TOKEN* tk)
+{
+ if (tk->tk_type != 12345)
+ return;
+ mad_free(tk->tk_mad);
+ Safefree(tk);
+}
+
+void
+Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
+{
+ MADPROP* mp;
+ MADPROP* tm;
+ if (tk->tk_type != 12345) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Invalid TOKEN object ignored");
+ return;
+ }
+ tm = tk->tk_mad;
+ if (!tm)
+ return;
+
+ /* faked up qw list? */
+ if (slot == '(' &&
+ tm->mad_type == MAD_SV &&
+ SvPVX((SV*)tm->mad_val)[0] == 'q')
+ slot = 'x';
+
+ if (o) {
+ mp = o->op_madprop;
+ if (mp) {
+ for (;;) {
+ /* pretend constant fold didn't happen? */
+ if (mp->mad_key == 'f' &&
+ (o->op_type == OP_CONST ||
+ o->op_type == OP_GV) )
+ {
+ token_getmad(tk,(OP*)mp->mad_val,slot);
+ return;
+ }
+ if (!mp->mad_next)
+ break;
+ mp = mp->mad_next;
+ }
+ mp->mad_next = tm;
+ mp = mp->mad_next;
+ }
+ else {
+ o->op_madprop = tm;
+ mp = o->op_madprop;
+ }
+ if (mp->mad_key == 'X')
+ mp->mad_key = slot; /* just change the first one */
+
+ tk->tk_mad = 0;
+ }
+ else
+ mad_free(tm);
+ Safefree(tk);
+}
+
+void
+Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
+{
+ MADPROP* mp;
+ if (!from)
+ return;
+ if (o) {
+ mp = o->op_madprop;
+ if (mp) {
+ for (;;) {
+ /* pretend constant fold didn't happen? */
+ if (mp->mad_key == 'f' &&
+ (o->op_type == OP_CONST ||
+ o->op_type == OP_GV) )
+ {
+ op_getmad(from,(OP*)mp->mad_val,slot);
+ return;
+ }
+ if (!mp->mad_next)
+ break;
+ mp = mp->mad_next;
+ }
+ mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
+ }
+ else {
+ o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
+ }
+ }
+}
+
+void
+Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
+{
+ MADPROP* mp;
+ if (!from)
+ return;
+ if (o) {
+ mp = o->op_madprop;
+ if (mp) {
+ for (;;) {
+ /* pretend constant fold didn't happen? */
+ if (mp->mad_key == 'f' &&
+ (o->op_type == OP_CONST ||
+ o->op_type == OP_GV) )
+ {
+ op_getmad(from,(OP*)mp->mad_val,slot);
+ return;
+ }
+ if (!mp->mad_next)
+ break;
+ mp = mp->mad_next;
+ }
+ mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
+ }
+ else {
+ o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
+ }
+ }
+ else {
+ PerlIO_printf(PerlIO_stderr(),
+ "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
+ op_free(from);
+ }
+}
+
+void
+Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
+{
+ MADPROP* tm;
+ if (!mp || !o)
+ return;
+ if (slot)
+ mp->mad_key = slot;
+ tm = o->op_madprop;
+ o->op_madprop = mp;
+ for (;;) {
+ if (!mp->mad_next)
+ break;
+ mp = mp->mad_next;
+ }
+ mp->mad_next = tm;
+}
+
+void
+Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
+{
+ if (!o)
+ return;
+ addmad(tm, &(o->op_madprop), slot);
+}
+
+void
+Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
+{
+ MADPROP* mp;
+ if (!tm || !root)
+ return;
+ if (slot)
+ tm->mad_key = slot;
+ mp = *root;
+ if (!mp) {
+ *root = tm;
+ return;
+ }
+ for (;;) {
+ if (!mp->mad_next)
+ break;
+ mp = mp->mad_next;
+ }
+ mp->mad_next = tm;
+}
+
+MADPROP *
+Perl_newMADsv(pTHX_ char key, SV* sv)
+{
+ return newMADPROP(key, MAD_SV, sv, 0);
+}
+
+MADPROP *
+Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+{
+ MADPROP *mp;
+ Newxz(mp, 1, MADPROP);
+ mp->mad_next = 0;
+ mp->mad_key = key;
+ mp->mad_vlen = vlen;
+ mp->mad_type = type;
+ mp->mad_val = val;
+/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
+ return mp;
+}
+
+void
+Perl_mad_free(pTHX_ MADPROP* mp)
+{
+/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
+ if (!mp)
+ return;
+ if (mp->mad_next)
+ mad_free(mp->mad_next);
+/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
+ PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
+ switch (mp->mad_type) {
+ case MAD_NULL:
+ break;
+ case MAD_PV:
+ Safefree((char*)mp->mad_val);
+ break;
+ case MAD_OP:
+ if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
+ op_free((OP*)mp->mad_val);
+ break;
+ case MAD_SV:
+ sv_free((SV*)mp->mad_val);
+ break;
+ default:
+ PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
+ break;
+ }
+ Safefree(mp);
+}
+
+#endif
+
OP *
Perl_newNULLLIST(pTHX)
{
Perl_force_list(pTHX_ OP *o)
{
if (!o || o->op_type != OP_LIST)
- o = newLISTOP(OP_LIST, 0, o, Nullop);
+ o = newLISTOP(OP_LIST, 0, o, NULL);
op_null(o);
return o;
}
OP *
Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
+ dVAR;
LISTOP *listop;
NewOp(1101, listop, 1, LISTOP);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
- OP* pushop;
- pushop = newOP(OP_PUSHMARK, 0);
+ OP* const pushop = newOP(OP_PUSHMARK, 0);
pushop->op_sibling = first;
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
OP *
Perl_newOP(pTHX_ I32 type, I32 flags)
{
+ dVAR;
OP *o;
NewOp(1101, o, 1, OP);
o->op_type = (OPCODE)type;
OP *
Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
{
+ dVAR;
UNOP *unop;
if (!first)
unop->op_type = (OPCODE)type;
unop->op_ppaddr = PL_ppaddr[type];
unop->op_first = first;
- unop->op_flags = flags | OPf_KIDS;
+ unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
OP *
Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
+ dVAR;
BINOP *binop;
NewOp(1101, binop, 1, BINOP);
binop->op_type = (OPCODE)type;
binop->op_ppaddr = PL_ppaddr[type];
binop->op_first = first;
- binop->op_flags = flags | OPf_KIDS;
+ binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
last = first;
binop->op_private = (U8)(1 | (flags >> 8));
return fold_constants((OP *)binop);
}
-static int
-uvcompare(const void *a, const void *b)
+static int uvcompare(const void *a, const void *b)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__pure__;
+static int uvcompare(const void *a, const void *b)
{
if (*((const UV *)a) < (*(const UV *)b))
return -1;
OP *
Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
- SV *tstr = ((SVOP*)expr)->op_sv;
- SV *rstr = ((SVOP*)repl)->op_sv;
+ dVAR;
+ SV * const tstr = ((SVOP*)expr)->op_sv;
+ SV * const rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
- U8 *t = (U8*)SvPV(tstr, tlen);
- U8 *r = (U8*)SvPV(rstr, rlen);
+ const U8 *t = (U8*)SvPV_const(tstr, tlen);
+ const U8 *r = (U8*)SvPV_const(rstr, rlen);
register I32 i;
register I32 j;
- I32 del;
- I32 complement;
- I32 squash;
I32 grows = 0;
register short *tbl;
+ const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
+ const I32 squash = o->op_private & OPpTRANS_SQUASH;
+ I32 del = o->op_private & OPpTRANS_DELETE;
PL_hints |= HINT_BLOCK_SCOPE;
- complement = o->op_private & OPpTRANS_COMPLEMENT;
- del = o->op_private & OPpTRANS_DELETE;
- squash = o->op_private & OPpTRANS_SQUASH;
if (SvUTF8(tstr))
o->op_private |= OPpTRANS_FROM_UTF;
o->op_private |= OPpTRANS_TO_UTF;
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- SV* listsv = newSVpvn("# comment\n",10);
- SV* transv = 0;
- U8* tend = t + tlen;
- U8* rend = r + rlen;
+ SV* const listsv = newSVpvs("# comment\n");
+ SV* transv = NULL;
+ const U8* tend = t + tlen;
+ const U8* rend = r + rlen;
STRLEN ulen;
UV tfirst = 1;
UV tlast = 0;
I32 bits;
I32 havefinal = 0;
U32 final = 0;
- I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
- I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
+ const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
+ const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
+ const U32 flags = UTF8_ALLOW_DEFAULT;
if (!from_utf) {
STRLEN len = tlen;
- tsave = t = bytes_to_utf8(t, &len);
+ t = tsave = bytes_to_utf8(t, &len);
tend = t + len;
}
if (!to_utf && rlen) {
STRLEN len = rlen;
- rsave = r = bytes_to_utf8(r, &len);
+ r = rsave = bytes_to_utf8(r, &len);
rend = r + len;
}
U8 tmpbuf[UTF8_MAXBYTES+1];
UV *cp;
UV nextmin = 0;
- New(1109, cp, 2*tlen, UV);
+ Newx(cp, 2*tlen, UV);
i = 0;
- transv = newSVpvn("",0);
+ transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
}
else {
t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
UNICODE_ALLOW_SUPER);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
- t = (U8*)SvPVX(transv);
+ t = (const U8*)SvPVX_const(transv);
tlen = SvCUR(transv);
tend = t + tlen;
Safefree(cp);
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
}
else
Safefree(cPVOPo->op_pv);
cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
SvREFCNT_dec(listsv);
- if (transv)
- SvREFCNT_dec(transv);
+ SvREFCNT_dec(transv);
if (!del && havefinal && rlen)
(void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
if (grows)
o->op_private |= OPpTRANS_GROWS;
- if (tsave)
- Safefree(tsave);
- if (rsave)
- Safefree(rsave);
+ Safefree(tsave);
+ Safefree(rsave);
+#ifdef PERL_MAD
+ op_getmad(expr,o,'e');
+ op_getmad(repl,o,'r');
+#else
op_free(expr);
op_free(repl);
+#endif
return o;
}
j = rlen - 1;
else
cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
- tbl[0x100] = rlen - j;
+ tbl[0x100] = (short)(rlen - j);
for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
}
}
if (grows)
o->op_private |= OPpTRANS_GROWS;
+#ifdef PERL_MAD
+ op_getmad(expr,o,'e');
+ op_getmad(repl,o,'r');
+#else
op_free(expr);
op_free(repl);
+#endif
return o;
}
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
+ dVAR;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
pmop->op_pmflags = pmop->op_pmpermflags;
#ifdef USE_ITHREADS
- {
- SV* repointer;
- if(av_len((AV*) PL_regex_pad[0]) > -1) {
- repointer = av_pop((AV*)PL_regex_pad[0]);
- pmop->op_pmoffset = SvIV(repointer);
- SvREPADTMP_off(repointer);
- sv_setiv(repointer,0);
- } else {
- repointer = newSViv(0);
- av_push(PL_regex_padav,SvREFCNT_inc(repointer));
- pmop->op_pmoffset = av_len(PL_regex_padav);
- PL_regex_pad = AvARRAY(PL_regex_padav);
- }
+ if (av_len((AV*) PL_regex_pad[0]) > -1) {
+ SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
+ pmop->op_pmoffset = SvIV(repointer);
+ SvREPADTMP_off(repointer);
+ sv_setiv(repointer,0);
+ } else {
+ SV * const repointer = newSViv(0);
+ av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
+ pmop->op_pmoffset = av_len(PL_regex_padav);
+ PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
/* link into pm list */
if (type != OP_TRANS && PL_curstash) {
- pmop->op_pmnext = HvPMROOT(PL_curstash);
- HvPMROOT(PL_curstash) = pmop;
+ 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);
}
OP *
Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
{
+ dVAR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
- OP* repl = Nullop;
+ OP* repl = NULL;
bool reglist;
if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
kid = cLISTOPx(expr)->op_first;
while (kid->op_sibling != repl)
kid = kid->op_sibling;
- kid->op_sibling = Nullop;
+ kid->op_sibling = NULL;
cLISTOPx(expr)->op_last = kid;
}
cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
{
/* convert single element list to element */
- OP* oe = expr;
+ OP* const oe = expr;
expr = cLISTOPx(oe)->op_first->op_sibling;
- cLISTOPx(oe)->op_first->op_sibling = Nullop;
- cLISTOPx(oe)->op_last = Nullop;
+ cLISTOPx(oe)->op_first->op_sibling = NULL;
+ cLISTOPx(oe)->op_last = NULL;
op_free(oe);
}
if (expr->op_type == OP_CONST) {
STRLEN plen;
- SV *pat = ((SVOP*)expr)->op_sv;
- char *p = SvPV(pat, 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 was_readonly = SvREADONLY(pat);
+
+ if (was_readonly) {
+ if (SvFAKE(pat)) {
+ sv_force_normal_flags(pat, 0);
+ assert(!SvREADONLY(pat));
+ was_readonly = 0;
+ } else {
+ SvREADONLY_off(pat);
+ }
+ }
+
sv_setpvn(pat, "\\s+", 3);
- p = SvPV(pat, plen);
+
+ SvFLAGS(pat) |= was_readonly;
+
+ p = SvPV_const(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
- PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
+ /* 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;
+#ifdef PERL_MAD
+ op_getmad(expr,(OP*)pm,'e');
+#else
op_free(expr);
+#endif
}
else {
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
if (repl) {
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
- curop = 0;
+ curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
else if (repl->op_type == OP_CONST)
curop = repl;
else {
- OP *lastop = 0;
+ 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_GV) {
- GV *gv = cGVOPx_gv(curop);
+ GV * const gv = cGVOPx_gv(curop);
repl_has_vars = 1;
if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
break;
repl_has_vars = 1;
}
else if (curop->op_type == OP_PUSHRE)
- ; /* Okay here, dangerous in newASSIGNOP */
+ NOOP; /* Okay here, dangerous in newASSIGNOP */
else
break;
}
OP *
Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
{
+ dVAR;
SVOP *svop;
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)type;
OP *
Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
{
+ dVAR;
PADOP *padop;
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
+ dVAR;
#ifdef USE_ITHREADS
if (gv)
GvIN_PAD_on(gv);
- return newPADOP(type, flags, SvREFCNT_inc(gv));
+ return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
#else
- return newSVOP(type, flags, SvREFCNT_inc(gv));
+ return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
#endif
}
OP *
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
+ dVAR;
PVOP *pvop;
NewOp(1101, pvop, 1, PVOP);
pvop->op_type = (OPCODE)type;
return CHECKOP(type, pvop);
}
+#ifdef PERL_MAD
+OP*
+#else
void
+#endif
Perl_package(pTHX_ OP *o)
{
+ dVAR;
const char *name;
STRLEN len;
+#ifdef PERL_MAD
+ OP *pegop;
+#endif
save_hptr(&PL_curstash);
save_item(PL_curstname);
- name = SvPV(cSVOPo->op_sv, len);
+ name = SvPV_const(cSVOPo->op_sv, len);
PL_curstash = gv_stashpvn(name, len, TRUE);
sv_setpvn(PL_curstname, name, len);
- op_free(o);
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
+
+#ifndef PERL_MAD
+ op_free(o);
+#else
+ if (!PL_madskills) {
+ op_free(o);
+ return NULL;
+ }
+
+ pegop = newOP(OP_NULL,0);
+ op_getmad(o,pegop,'P');
+ return pegop;
+#endif
}
+#ifdef PERL_MAD
+OP*
+#else
void
+#endif
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
+ dVAR;
OP *pack;
OP *imop;
OP *veop;
+#ifdef PERL_MAD
+ OP *pegop = newOP(OP_NULL,0);
+#endif
if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
- veop = Nullop;
+ if (PL_madskills)
+ op_getmad(idop,pegop,'U');
+
+ veop = NULL;
- if (version != Nullop) {
- SV *vesv = ((SVOP*)version)->op_sv;
+ if (version) {
+ SV * const vesv = ((SVOP*)version)->op_sv;
- if (arg == Nullop && !SvNIOKp(vesv)) {
+ if (PL_madskills)
+ op_getmad(version,pegop,'V');
+ if (!arg && !SvNIOKp(vesv)) {
arg = version;
}
else {
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
- meth = newSVpvn("VERSION",7);
- sv_upgrade(meth, SVt_PVIV);
- (void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ meth = newSVpvs_share("VERSION");
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(version)),
}
/* Fake up an import/unimport */
- if (arg && arg->op_type == OP_STUB)
+ if (arg && arg->op_type == OP_STUB) {
+ if (PL_madskills)
+ op_getmad(arg,pegop,'S');
imop = arg; /* no import on explicit () */
+ }
else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
- imop = Nullop; /* use 5.0; */
+ imop = NULL; /* use 5.0; */
+ if (!aver)
+ idop->op_private |= OPpCONST_NOVER;
}
else {
SV *meth;
+ if (PL_madskills)
+ op_getmad(arg,pegop,'A');
+
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to import/unimport */
- meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
- (void)SvUPGRADE(meth, SVt_PVIV);
- (void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ meth = aver
+ ? newSVpvs_share("import") : newSVpvs_share("unimport");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
- newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
- Nullop,
- Nullop,
+ newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
+ NULL,
+ NULL,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
- newSTATEOP(0, Nullch, veop)),
- newSTATEOP(0, Nullch, imop) ));
+ newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
+ newSTATEOP(0, NULL, veop)),
+ newSTATEOP(0, NULL, imop) ));
/* The "did you use incorrect case?" warning used to be here.
* The problem is that on case-insensitive filesystems one
PL_copline = NOLINE;
PL_expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
+
+#ifdef PERL_MAD
+ if (!PL_madskills) {
+ /* FIXME - don't allocate pegop if !PL_madskills */
+ op_free(pegop);
+ return NULL;
+ }
+ return pegop;
+#endif
}
/*
void
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
- OP *modname, *veop, *imop;
+ dVAR;
+ OP *veop, *imop;
- modname = newSVOP(OP_CONST, 0, name);
+ OP * const modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
}
else
- veop = Nullop;
+ veop = NULL;
if (flags & PERL_LOADMOD_NOIMPORT) {
imop = sawparens(newNULLLIST());
}
}
else {
SV *sv;
- imop = Nullop;
+ imop = NULL;
sv = va_arg(*args, SV*);
while (sv) {
imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
}
OP *
-Perl_dofile(pTHX_ OP *term)
+Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
+ dVAR;
OP *doop;
- GV *gv;
+ GV *gv = NULL;
- gv = gv_fetchpv("do", FALSE, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
+ if (!force_builtin) {
+ gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
+ gv = gvp ? *gvp : NULL;
+ }
+ }
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ newGVOP(OP_GV, 0, gv))))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
}
STATIC I32
-S_list_assignment(pTHX_ register const OP *o)
+S_is_list_assignment(pTHX_ register const OP *o)
{
+ unsigned type;
+ U8 flags;
+
if (!o)
return TRUE;
- if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
+ if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
o = cUNOPo->op_first;
- if (o->op_type == OP_COND_EXPR) {
- const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
- const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
+ flags = o->op_flags;
+ type = o->op_type;
+ if (type == OP_COND_EXPR) {
+ const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
+ const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
if (t && f)
return TRUE;
return FALSE;
}
- if (o->op_type == OP_LIST &&
- (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+ if (type == OP_LIST &&
+ (flags & OPf_WANT) == OPf_WANT_SCALAR &&
o->op_private & OPpLVAL_INTRO)
return FALSE;
- if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
- o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
- o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
+ if (type == OP_LIST || flags & OPf_PARENS ||
+ type == OP_RV2AV || type == OP_RV2HV ||
+ type == OP_ASLICE || type == OP_HSLICE)
return TRUE;
- if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
+ if (type == OP_PADAV || type == OP_PADHV)
return TRUE;
- if (o->op_type == OP_RV2SV)
+ if (type == OP_RV2SV)
return FALSE;
return FALSE;
OP *
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
+ dVAR;
OP *o;
if (optype) {
}
}
- if (list_assignment(left)) {
+ if (is_list_assignment(left)) {
OP *curop;
PL_modcount = 0;
- PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
+ /* Grandfathering $[ assignment here. Bletch.*/
+ /* Only simple assignments like C<< ($[) = 1 >> are allowed */
+ PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
left = mod(left, OP_AASSIGN);
if (PL_eval_start)
PL_eval_start = 0;
- else {
- op_free(left);
- op_free(right);
- return Nullop;
- }
- /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
- if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
- && right->op_type == OP_STUB
- && (left->op_private & OPpLVAL_INTRO))
- {
- op_free(right);
- left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
- return left;
+ else if (left->op_type == OP_CONST) {
+ /* FIXME for MAD */
+ /* Result of assignment is always 1 (or we'd be dead already) */
+ return newSVOP(OP_CONST, 0, newSViv(1));
}
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
break;
- SvCUR(gv) = PL_generation;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
}
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
if (PAD_COMPNAME_GEN(curop->op_targ)
== (STRLEN)PL_generation)
break;
- PAD_COMPNAME_GEN(curop->op_targ)
- = PL_generation;
+ PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
}
else if (curop->op_type == OP_RV2CV)
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
- if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
break;
- SvCUR(gv) = PL_generation;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ GvASSIGN_GENERATION_set(gv, PL_generation);
}
}
else
o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT) {
- OP* tmpop;
- if ((tmpop = ((LISTOP*)right)->op_first) &&
- tmpop->op_type == OP_PUSHRE)
- {
- PMOP *pm = (PMOP*)tmpop;
+ OP* tmpop = ((LISTOP*)right)->op_first;
+ if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
+ PMOP * const pm = (PMOP*)tmpop;
if (left->op_type == OP_RV2AV &&
!(left->op_private & OPpLVAL_INTRO) &&
!(o->op_private & OPpASSIGN_COMMON) )
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
- cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
+ cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
pm->op_pmflags |= PMf_ONCE;
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
- tmpop->op_sibling = Nullop; /* don't free split */
+ tmpop->op_sibling = NULL; /* don't free split */
right->op_next = tmpop->op_next; /* fix starting loc */
+#ifdef PERL_MAD
+ op_getmad(o,right,'R'); /* blow off assign */
+#else
op_free(o); /* blow off assign */
+#endif
right->op_flags &= ~OPf_WANT;
/* "I don't know and I don't care." */
return right;
if (PL_eval_start)
PL_eval_start = 0;
else {
+ /* FIXME for MAD */
op_free(o);
- return Nullop;
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
+ o->op_private |= OPpCONST_ARYBASE;
}
}
return o;
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
+ dVAR;
const U32 seq = intro_my();
register COP *cop;
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = (U8)flags;
- cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(cop, PL_hints);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- PL_compiling.op_private = cop->op_private;
+ CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
if (label) {
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
- cop->cop_arybase = PL_curcop->cop_arybase;
- if (specialWARN(PL_curcop->cop_warnings))
- cop->cop_warnings = PL_curcop->cop_warnings ;
- else
- cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+ 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) {
+ HINTS_REFCNT_LOCK;
+ cop->cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
if (PL_copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
- (void)SvIOK_on(*svp);
- SvIVX(*svp) = PTR2IV(cop);
+ 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));
}
}
OP *
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
{
+ dVAR;
return new_logop(type, flags, &first, &other);
}
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
+ dVAR;
LOGOP *logop;
OP *o;
OP *first = *firstp;
- OP *other = *otherp;
+ OP * const other = *otherp;
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
scalarboolean(first);
/* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
- if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
+ if (first->op_type == OP_NOT
+ && (first->op_flags & OPf_SPECIAL)
+ && (first->op_flags & OPf_KIDS)) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
first = *firstp = cUNOPo->op_first;
if (o->op_next)
first->op_next = o->op_next;
- cUNOPo->op_first = Nullop;
+ cUNOPo->op_first = NULL;
+#ifdef PERL_MAD
+ op_getmad(o,first,'O');
+#else
op_free(o);
+#endif
}
}
if (first->op_type == OP_CONST) {
if (first->op_private & OPpCONST_STRICT)
no_bareword_allowed(first);
- else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
+ else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
- op_free(first);
- *firstp = Nullop;
+ *firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (PL_madskills) {
+ OP *newop = newUNOP(OP_NULL, 0, other);
+ op_getmad(first, newop, '1');
+ newop->op_targ = type; /* set "was" field */
+ return newop;
+ }
+ op_free(first);
return other;
}
else {
"Deprecated use of my() in false conditional");
}
- op_free(other);
- *otherp = Nullop;
+ *otherp = NULL;
if (first->op_type == OP_CONST)
first->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (PL_madskills) {
+ first = newUNOP(OP_NULL, 0, first);
+ op_getmad(other, first, '2');
+ first->op_targ = type; /* set "was" field */
+ }
+ else
+ op_free(other);
return first;
}
}
- else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
- type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
+ else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
+ && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
{
- const OP *k1 = ((UNOP*)first)->op_first;
- const OP *k2 = k1->op_sibling;
+ const OP * const k1 = ((UNOP*)first)->op_first;
+ const OP * const k2 = k1->op_sibling;
OPCODE warnop = 0;
switch (first->op_type)
{
logop->op_type = (OPCODE)type;
logop->op_ppaddr = PL_ppaddr[type];
logop->op_first = first;
- logop->op_flags = flags | OPf_KIDS;
+ logop->op_flags = (U8)(flags | OPf_KIDS);
logop->op_other = LINKLIST(other);
logop->op_private = (U8)(1 | (flags >> 8));
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
+ dVAR;
LOGOP *logop;
OP *start;
OP *o;
scalarboolean(first);
if (first->op_type == OP_CONST) {
if (first->op_private & OPpCONST_BARE &&
- first->op_private & OPpCONST_STRICT) {
- no_bareword_allowed(first);
- }
+ 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
op_free(first);
op_free(trueop);
+#endif
return falseop;
}
}
logop->op_type = OP_COND_EXPR;
logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_first = first;
- logop->op_flags = flags | OPf_KIDS;
+ logop->op_flags = (U8)(flags | OPf_KIDS);
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
+ dVAR;
LOGOP *range;
OP *flip;
OP *flop;
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
+ dVAR;
OP* listop;
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
(block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
- (void)debuggable;
+
+ PERL_UNUSED_ARG(debuggable);
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
- const OP *k1 = ((UNOP*)expr)->op_first;
- const OP *k2 = (k1) ? k1->op_sibling : NULL;
+ const OP * const k1 = ((UNOP*)expr)->op_first;
+ const OP * const k2 = k1 ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
break;
case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
+ if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
}
OP *
-Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
+Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
+whileline, OP *expr, OP *block, OP *cont, I32 has_my)
{
+ dVAR;
OP *redo;
- OP *next = 0;
+ OP *next = NULL;
OP *listop;
OP *o;
U8 loopflags = 0;
- (void)debuggable;
-
- if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
- || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
- expr = newUNOP(OP_DEFINED, 0,
- newASSIGNOP(0, newDEFSVOP(), 0, expr) );
- } else if (expr && (expr->op_flags & OPf_KIDS)) {
- const OP *k1 = ((UNOP*)expr)->op_first;
- const OP *k2 = (k1) ? k1->op_sibling : NULL;
- switch (expr->op_type) {
- case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
- && (k2->op_flags & OPf_STACKED)
- && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
- expr = newUNOP(OP_DEFINED, 0, expr);
- break;
- case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
- || k1->op_type == OP_GLOB
- || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
- expr = newUNOP(OP_DEFINED, 0, expr);
- break;
+ PERL_UNUSED_ARG(debuggable);
+
+ if (expr) {
+ if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
+ expr = newUNOP(OP_DEFINED, 0,
+ newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr->op_flags & OPf_KIDS) {
+ const OP * const k1 = ((UNOP*)expr)->op_first;
+ const OP * const k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1 && (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
+ || k1->op_type == OP_EACH))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
}
if (!block)
block = newOP(OP_NULL, 0);
- else if (cont) {
+ else if (cont || has_my) {
block = scope(block);
}
next = LINKLIST(cont);
}
if (expr) {
- OP *unstack = newOP(OP_UNSTACK, 0);
+ OP * const unstack = newOP(OP_UNSTACK, 0);
if (!next)
next = unstack;
cont = append_elem(OP_LINESEQ, cont, unstack);
}
+ assert(block);
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
+ assert(listop);
redo = LINKLIST(listop);
if (expr) {
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
- return Nullop; /* listop already freed by new_logop */
+ return NULL; /* listop already freed by new_logop */
}
if (listop)
((LISTOP*)listop)->op_last->op_next =
}
OP *
-Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
+Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
{
+ dVAR;
LOOP *loop;
OP *wop;
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
+ OP *madsv = NULL;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
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)
+ iterpflags |= OPpITER_DEF;
}
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
padoff = sv->op_targ;
- sv->op_targ = 0;
- op_free(sv);
- sv = Nullop;
+ if (PL_madskills)
+ madsv = sv;
+ else {
+ sv->op_targ = 0;
+ op_free(sv);
+ }
+ sv = NULL;
}
else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
padoff = sv->op_targ;
- sv->op_targ = 0;
- iterflags |= OPf_SPECIAL;
- op_free(sv);
- sv = Nullop;
+ 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;
}
else {
- const I32 offset = pad_findmy("$_");
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ const PADOFFSET offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
else {
padoff = offset;
}
+ iterpflags |= OPpITER_DEF;
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
* set the STACKED flag to indicate that these values are to be
* treated as min/max values by 'pp_iterinit'.
*/
- UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
- LOGOP* range = (LOGOP*) flip->op_first;
- OP* left = range->op_first;
- OP* right = left->op_sibling;
+ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ LOGOP* const range = (LOGOP*) flip->op_first;
+ OP* const left = range->op_first;
+ OP* const right = left->op_sibling;
LISTOP* listop;
range->op_flags &= ~OPf_KIDS;
- range->op_first = Nullop;
+ range->op_first = NULL;
listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
listop->op_first->op_next = range->op_next;
right->op_next = (OP*)listop;
listop->op_next = listop->op_first;
+#ifdef PERL_MAD
+ op_getmad(expr,(OP*)listop,'O');
+#else
op_free(expr);
+#endif
expr = (OP*)(listop);
op_null(expr);
iterflags |= OPf_STACKED;
loop = tmp;
}
#else
- Renew(loop, 1, LOOP);
+ loop = PerlMemShared_realloc(loop, sizeof(LOOP));
#endif
loop->op_targ = padoff;
- wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
+ wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
+ if (madsv)
+ op_getmad(madsv, (OP*)loop, 'v');
PL_copline = forline;
return newSTATEOP(0, label, wop);
}
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
+ dVAR;
OP *o;
- STRLEN n_a;
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
o = newOP(type, OPf_SPECIAL);
else {
o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
- ? SvPVx(((SVOP*)label)->op_sv, n_a)
+ ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
+#ifdef PERL_MAD
+ op_getmad(label,o,'L');
+#else
op_free(label);
+#endif
}
else {
/* Check whether it's going to be a goto &function */
return o;
}
+/* if the condition is a literal array or hash
+ (or @{ ... } etc), make a reference to it.
+ */
+STATIC OP *
+S_ref_array_or_hash(pTHX_ OP *cond)
+{
+ if (cond
+ && (cond->op_type == OP_RV2AV
+ || cond->op_type == OP_PADAV
+ || cond->op_type == OP_RV2HV
+ || cond->op_type == OP_PADHV))
+
+ return newUNOP(OP_REFGEN,
+ 0, mod(cond, OP_REFGEN));
+
+ else
+ return cond;
+}
+
+/* These construct the optree fragments representing given()
+ and when() blocks.
+
+ entergiven and enterwhen are LOGOPs; the op_other pointer
+ points up to the associated leave op. We need this so we
+ can put it in the context and make break/continue work.
+ (Also, of course, pp_enterwhen will jump straight to
+ op_other if the match fails.)
+ */
+
+STATIC
+OP *
+S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
+ I32 enter_opcode, I32 leave_opcode,
+ PADOFFSET entertarg)
+{
+ dVAR;
+ LOGOP *enterop;
+ OP *o;
+
+ NewOp(1101, enterop, 1, LOGOP);
+ enterop->op_type = enter_opcode;
+ enterop->op_ppaddr = PL_ppaddr[enter_opcode];
+ enterop->op_flags = (U8) OPf_KIDS;
+ enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+ enterop->op_private = 0;
+
+ o = newUNOP(leave_opcode, 0, (OP *) enterop);
+
+ if (cond) {
+ enterop->op_first = scalar(cond);
+ cond->op_sibling = block;
+
+ o->op_next = LINKLIST(cond);
+ cond->op_next = (OP *) enterop;
+ }
+ else {
+ /* This is a default {} block */
+ enterop->op_first = block;
+ enterop->op_flags |= OPf_SPECIAL;
+
+ o->op_next = (OP *) enterop;
+ }
+
+ CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
+ entergiven and enterwhen both
+ use ck_null() */
+
+ enterop->op_next = LINKLIST(block);
+ block->op_next = enterop->op_other = o;
+
+ return o;
+}
+
+/* Does this look like a boolean operation? For these purposes
+ a boolean operation is:
+ - a subroutine call [*]
+ - a logical connective
+ - a comparison operator
+ - a filetest operator, with the exception of -s -M -A -C
+ - defined(), exists() or eof()
+ - /$re/ or $foo =~ /$re/
+
+ [*] possibly surprising
+ */
+STATIC
+bool
+S_looks_like_bool(pTHX_ const OP *o)
+{
+ dVAR;
+ switch(o->op_type) {
+ case OP_OR:
+ return looks_like_bool(cLOGOPo->op_first);
+
+ case OP_AND:
+ return (
+ looks_like_bool(cLOGOPo->op_first)
+ && looks_like_bool(cLOGOPo->op_first->op_sibling));
+
+ case OP_ENTERSUB:
+
+ case OP_NOT: case OP_XOR:
+ /* Note that OP_DOR is not here */
+
+ case OP_EQ: case OP_NE: case OP_LT:
+ case OP_GT: case OP_LE: case OP_GE:
+
+ case OP_I_EQ: case OP_I_NE: case OP_I_LT:
+ case OP_I_GT: case OP_I_LE: case OP_I_GE:
+
+ case OP_SEQ: case OP_SNE: case OP_SLT:
+ case OP_SGT: case OP_SLE: case OP_SGE:
+
+ case OP_SMARTMATCH:
+
+ case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
+ case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
+ case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
+ case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
+ case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
+ case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
+ case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
+ case OP_FTTEXT: case OP_FTBINARY:
+
+ case OP_DEFINED: case OP_EXISTS:
+ case OP_MATCH: case OP_EOF:
+
+ return TRUE;
+
+ case OP_CONST:
+ /* Detect comparisons that have been optimized away */
+ if (cSVOPo->op_sv == &PL_sv_yes
+ || cSVOPo->op_sv == &PL_sv_no)
+
+ return TRUE;
+
+ /* FALL THROUGH */
+ default:
+ return FALSE;
+ }
+}
+
+OP *
+Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
+{
+ dVAR;
+ assert( cond );
+ return newGIVWHENOP(
+ ref_array_or_hash(cond),
+ block,
+ OP_ENTERGIVEN, OP_LEAVEGIVEN,
+ defsv_off);
+}
+
+/* If cond is null, this is a default {} block */
+OP *
+Perl_newWHENOP(pTHX_ OP *cond, OP *block)
+{
+ const bool cond_llb = (!cond || looks_like_bool(cond));
+ OP *cond_op;
+
+ if (cond_llb)
+ cond_op = cond;
+ else {
+ cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
+ newDEFSVOP(),
+ scalar(ref_array_or_hash(cond)));
+ }
+
+ return newGIVWHENOP(
+ cond_op,
+ append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
+ OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+}
+
/*
=for apidoc cv_undef
void
Perl_cv_undef(pTHX_ CV *cv)
{
+ dVAR;
#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvXSUB(cv)) {
+ if (CvFILE(cv) && !CvISXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
CvFILE(cv) = 0;
#endif
- if (!CvXSUB(cv) && CvROOT(cv)) {
- if (CvDEPTH(cv))
+ if (!CvISXSUB(cv) && CvROOT(cv)) {
+ if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
ENTER;
PAD_SAVE_SETNULLPAD();
op_free(CvROOT(cv));
- CvROOT(cv) = Nullop;
+ CvROOT(cv) = NULL;
+ CvSTART(cv) = NULL;
LEAVE;
}
SvPOK_off((SV*)cv); /* forget prototype */
- CvGV(cv) = Nullgv;
+ CvGV(cv) = NULL;
pad_undef(cv);
if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
if (!CvWEAKOUTSIDE(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = Nullcv;
+ CvOUTSIDE(cv) = NULL;
}
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
}
- if (CvXSUB(cv)) {
- CvXSUB(cv) = 0;
+ if (CvISXSUB(cv) && CvXSUB(cv)) {
+ CvXSUB(cv) = NULL;
}
/* delete all flags except WEAKOUTSIDE */
CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
}
void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
- SV* msg = sv_newmortal();
- SV* name = Nullsv;
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len)
+{
+ /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+ relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
+ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
+ || (p && (len != SvCUR(cv) /* Not the same length. */
+ || memNE(p, SvPVX_const(cv), len))))
+ && ckWARN_d(WARN_PROTOTYPE)) {
+ SV* const msg = sv_newmortal();
+ SV* name = NULL;
if (gv)
- gv_efullname3(name = sv_newmortal(), gv, Nullch);
+ gv_efullname3(name = sv_newmortal(), gv, NULL);
sv_setpv(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
if (SvPOK(cv))
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
else
- Perl_sv_catpv(aTHX_ msg, ": none");
- sv_catpv(msg, " vs ");
+ sv_catpvs(msg, ": none");
+ sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+ Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
- sv_catpv(msg, "none");
+ sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
}
}
SV *
Perl_cv_const_sv(pTHX_ CV *cv)
{
- if (!cv || !CvCONST(cv))
- return Nullsv;
- return (SV*)CvXSUBANY(cv).any_ptr;
+ PERL_UNUSED_CONTEXT;
+ if (!cv)
+ return NULL;
+ if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
+ return NULL;
+ return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
SV *
Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
{
- SV *sv = Nullsv;
+ dVAR;
+ SV *sv = NULL;
if (!o)
- return Nullsv;
+ return NULL;
if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
o = cLISTOPo->op_first->op_sibling;
for (; o; o = o->op_next) {
- OPCODE type = o->op_type;
+ const OPCODE type = o->op_type;
if (sv && o->op_next == o)
return sv;
if (type == OP_LEAVESUB || type == OP_RETURN)
break;
if (sv)
- return Nullsv;
+ return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
- return Nullsv;
+ return NULL;
}
else if (cv && type == OP_PADSV) {
if (CvCONST(cv)) { /* newly cloned anon */
/* the candidate should have 1 ref from this pad and 1 ref
* from the parent */
if (!sv || SvREFCNT(sv) != 2)
- return Nullsv;
+ return NULL;
sv = newSVsv(sv);
SvREADONLY_on(sv);
return sv;
}
}
else {
- return Nullsv;
+ return NULL;
}
}
return sv;
}
+#ifdef PERL_MAD
+OP *
+#else
void
+#endif
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- (void)floor;
+#if 0
+ /* This would be the return value, but the return cannot be reached. */
+ OP* pegop = newOP(OP_NULL, 0);
+#endif
+
+ PERL_UNUSED_ARG(floor);
+
if (o)
SAVEFREEOP(o);
if (proto)
if (block)
SAVEFREEOP(block);
Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+#ifdef PERL_MAD
+ NORETURN_FUNCTION_END;
+#endif
}
CV *
Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
{
- return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
+ return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
}
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- STRLEN n_a;
- const char *name;
+ dVAR;
const char *aname;
GV *gv;
- char *ps;
- register CV *cv=0;
+ const char *ps;
+ STRLEN ps_len;
+ register CV *cv = NULL;
SV *const_sv;
-
- name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+ /* If the subroutine has no body, no attributes, and no builtin attributes
+ then it's just a sub declaration, and we may be able to get away with
+ storing with a placeholder scalar in the symbol table, rather than a
+ full GV and CV. If anything is present then it will take a full CV to
+ store it. */
+ const I32 gv_fetch_flags
+ = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || PL_madskills)
+ ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
+ const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
if (proto) {
assert(proto->op_type == OP_CONST);
- ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
+ ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
}
else
- ps = Nullch;
+ ps = NULL;
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- aname = SvPVX(sv);
+ aname = SvPVX_const(sv);
}
else
- aname = Nullch;
- gv = name ? gv_fetchsv(cSVOPo->op_sv,
- GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
- SVt_PVCV)
+ aname = NULL;
+
+ gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
: gv_fetchpv(aname ? aname
: (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
- SVt_PVCV);
+ gv_fetch_flags, SVt_PVCV);
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
+ if (!PL_madskills) {
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ }
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto((CV*)gv, NULL, ps);
+ cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
}
if (ps)
- sv_setpv((SV*)gv, ps);
+ sv_setpvn((SV*)gv, ps, ps_len);
else
sv_setiv((SV*)gv, -1);
SvREFCNT_dec(PL_compcv);
goto done;
}
- cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
+ cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
#ifdef GV_UNIQUE_CHECK
if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
}
#endif
- if (!block || !ps || *ps || attrs)
- const_sv = Nullsv;
+ if (!block || !ps || *ps || attrs
+ || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )
+ const_sv = NULL;
else
- const_sv = op_const_sv(block, Nullcv);
+ const_sv = op_const_sv(block, NULL);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto(cv, gv, ps);
+ cv_ckproto_len(cv, gv, ps, ps_len);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- if (!block && !attrs) {
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )&& !attrs) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
SAVEFREESV(PL_compcv);
goto done;
}
- /* ahem, death to those who redefine active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
- if (block) {
+ if (block
+#ifdef PERL_MAD
+ && block->op_type != OP_NULL
+#endif
+ ) {
if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
: "Subroutine %s redefined", name);
CopLINE_set(PL_curcop, oldline);
}
- SvREFCNT_dec(cv);
- cv = Nullcv;
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ cv = NULL;
}
}
}
if (const_sv) {
- (void)SvREFCNT_inc(const_sv);
+ SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
- sv_setpv((SV*)cv, ""); /* prototype is "" */
+ sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
+ CvISXSUB_on(cv);
}
else {
- GvCV(gv) = Nullcv;
+ GvCV(gv) = NULL;
cv = newCONSTSUB(NULL, name, const_sv);
}
+ PL_sub_generation++;
+ if (PL_madskills)
+ goto install_block;
op_free(block);
SvREFCNT_dec(PL_compcv);
PL_compcv = NULL;
- PL_sub_generation++;
goto done;
}
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
* before we clobber PL_compcv.
*/
- if (cv && !block) {
+ if (cv && (!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
rcv = (SV*)cv;
/* Might have had built-in attributes applied -- propagate them. */
CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
- if (!block) {
+ if (
+#ifdef PERL_MAD
+ (
+#endif
+ !block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL) && !PL_madskills
+#endif
+ ) {
/* got here with just attrs -- work done, so bug out */
SAVEFREESV(PL_compcv);
goto done;
cv = PL_compcv;
if (name) {
GvCV(gv) = cv;
+ if (PL_madskills) {
+ if (strEQ(name, "import")) {
+ PL_formfeed = (SV*)cv;
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+ }
+ }
GvCVGEN(gv) = 0;
PL_sub_generation++;
}
CvSTASH(cv) = PL_curstash;
if (ps)
- sv_setpv((SV*)cv, ps);
+ sv_setpvn((SV*)cv, ps, ps_len);
if (PL_error_count) {
op_free(block);
- block = Nullop;
+ block = NULL;
if (name) {
const char *s = strrchr(name, ':');
s = s ? s+1 : name;
}
}
}
+ install_block:
if (!block)
goto done;
else {
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
+ OP* const newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+ op_getmad(block,newblock,'B');
+#else
op_free(block);
- block = newSTATEOP(0, Nullch, 0);
+#endif
+ block = newblock;
}
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
if (name || aname) {
const char *s;
- const char *tname = (name ? name : aname);
+ const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV *sv = NEWSV(0,0);
- SV *tmpstr = sv_newmortal();
- GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
- CV *pcv;
+ SV * const sv = newSV(0);
+ SV * const tmpstr = sv_newmortal();
+ GV * const db_postponed = gv_fetchpvs("DB::postponed",
+ GV_ADDMULTI, SVt_PVHV);
HV *hv;
Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
CopFILE(PL_curcop),
(long)PL_subline, (long)CopLINE(PL_curcop));
- gv_efullname3(tmpstr, gv, Nullch);
- hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ gv_efullname3(tmpstr, gv, NULL);
+ hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
- && (pcv = GvCV(db_postponed)))
- {
- dSP;
- PUSHMARK(SP);
- XPUSHs(tmpstr);
- PUTBACK;
- call_sv((SV*)pcv, G_DISCARD);
+ if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+ CV * const pcv = GvCV(db_postponed);
+ if (pcv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ call_sv((SV*)pcv, G_DISCARD);
+ }
}
}
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
CV *
Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
{
+ dVAR;
CV* cv;
+#ifdef USE_ITHREADS
+ const char *const temp_p = CopFILE(PL_curcop);
+ const STRLEN len = temp_p ? strlen(temp_p) : 0;
+#else
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ STRLEN len;
+ const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+ char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+ /* 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);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- sv_setpv((SV*)cv, ""); /* prototype is "" */
+ /* 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);
+#ifdef USE_ITHREADS
if (stash)
CopSTASH_free(PL_curcop);
-
+#endif
LEAVE;
return cv;
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
- GV *gv = gv_fetchpv(name ? name :
+ dVAR;
+ GV * const gv = gv_fetchpv(name ? name :
(PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
GV_ADDMULTI, SVt_PVCV);
register CV *cv;
if (!subaddr)
Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
- if ((cv = (name ? GvCV(gv) : Nullcv))) {
+ if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
SvREFCNT_dec(cv);
- cv = 0;
+ cv = NULL;
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
- && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"
- ,name);
- CopLINE_set(PL_curcop, oldline);
+ /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
+ if (ckWARN(WARN_REDEFINE)) {
+ GV * const gvcv = CvGV(cv);
+ if (gvcv) {
+ HV * const stash = GvSTASH(gvcv);
+ if (stash) {
+ const char *redefined_name = HvNAME_get(stash);
+ if ( strEQ(redefined_name,"autouse") ) {
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_copline);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined"
+ ,name);
+ CopLINE_set(PL_curcop, oldline);
+ }
+ }
+ }
}
SvREFCNT_dec(cv);
- cv = 0;
+ cv = NULL;
}
}
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
- cv = (CV*)NEWSV(1105,0);
+ cv = (CV*)newSV(0);
sv_upgrade((SV *)cv, SVt_PVCV);
if (name) {
GvCV(gv) = cv;
(void)gv_fetchfile(filename);
CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
+ CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
if (name) {
return cv;
}
+#ifdef PERL_MAD
+OP *
+#else
void
+#endif
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
+ dVAR;
register CV *cv;
- GV *gv;
+#ifdef PERL_MAD
+ OP* pegop = newOP(OP_NULL, 0);
+#endif
+
+ GV * const gv = o
+ ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
+ : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
- if (o)
- gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
- else
- gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
-
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
+#ifdef PERL_MAD
+ op_getmad(o,pegop,'n');
+ op_getmad_weak(block, pegop, 'b');
+#else
op_free(o);
+#endif
PL_copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_MAD
+ return pegop;
+#endif
}
OP *
OP *
Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
{
- return newANONATTRSUB(floor, proto, Nullop, block);
+ return newANONATTRSUB(floor, proto, NULL, block);
}
OP *
OP *
Perl_oopsAV(pTHX_ OP *o)
{
+ dVAR;
switch (o->op_type) {
case OP_PADSV:
o->op_type = OP_PADAV;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
+ dVAR;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
OP *
Perl_newAVREF(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
OP *
Perl_newHVREF(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADHV;
o->op_ppaddr = PL_ppaddr[OP_PADHV];
}
OP *
-Perl_oopsCV(pTHX_ OP *o)
-{
- Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
- /* STUB */
- (void)o;
-#ifndef HASATTRIBUTE
- /* No __attribute__, so the compiler doesn't know that croak never returns
- */
- return 0;
-#endif
-}
-
-OP *
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
return newUNOP(OP_RV2CV, flags, scalar(o));
OP *
Perl_newSVREF(pTHX_ OP *o)
{
+ dVAR;
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADSV;
o->op_ppaddr = PL_ppaddr[OP_PADSV];
Perl_ck_anoncode(pTHX_ OP *o)
{
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
- cSVOPo->op_sv = Nullsv;
+ if (!PL_madskills)
+ cSVOPo->op_sv = NULL;
return o;
}
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
+ dVAR;
#define OP_IS_NUMCOMPARE(op) \
((op) == OP_LT || (op) == OP_I_LT || \
(op) == OP_GT || (op) == OP_I_GT || \
|| o->op_type == OP_BIT_AND
|| o->op_type == OP_BIT_XOR))
{
- const OP * left = cBINOPo->op_first;
- const OP * right = left->op_sibling;
+ const OP * const left = cBINOPo->op_first;
+ const OP * const right = left->op_sibling;
if ((OP_IS_NUMCOMPARE(left->op_type) &&
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- const OP *kid = cUNOPo->op_first;
+ const OP * const kid = cUNOPo->op_first;
+ PERL_UNUSED_CONTEXT;
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
OP *
Perl_ck_spair(pTHX_ OP *o)
{
+ dVAR;
if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
o = modkids(ck_fun(o), type);
kid = cUNOPo->op_first;
newop = kUNOP->op_first->op_sibling;
- if (newop &&
- (newop->op_sibling ||
- !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
- newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
- newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
- return o;
- }
+ if (newop) {
+ const OPCODE type = newop->op_type;
+ if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
+ type == OP_PADAV || type == OP_PADHV ||
+ type == OP_RV2AV || type == OP_RV2HV)
+ return o;
+ }
+#ifdef PERL_MAD
+ op_getmad(kUNOP->op_first,newop,'K');
+#else
op_free(kUNOP->op_first);
+#endif
kUNOP->op_first = newop;
}
o->op_ppaddr = PL_ppaddr[++o->op_type];
o = ck_fun(o);
o->op_private = 0;
if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
switch (kid->op_type) {
case OP_ASLICE:
o->op_flags |= OPf_SPECIAL;
OP *
Perl_ck_eof(pTHX_ OP *o)
{
- const I32 type = o->op_type;
+ dVAR;
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
+ OP * const newop
+ = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
op_free(o);
- o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+#endif
+ o = newop;
}
return ck_fun(o);
}
OP *
Perl_ck_eval(pTHX_ OP *o)
{
+ dVAR;
PL_hints |= HINT_BLOCK_SCOPE;
if (o->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (!kid) {
o->op_flags &= ~OPf_KIDS;
}
else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
+#ifdef PERL_MAD
+ OP* const oldo = o;
+#endif
cUNOPo->op_first = 0;
+#ifndef PERL_MAD
op_free(o);
+#endif
NewOp(1101, enter, 1, LOGOP);
enter->op_type = OP_ENTERTRY;
o->op_type = OP_LEAVETRY;
o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
enter->op_other = o;
+ op_getmad(oldo,o,'O');
return o;
}
else {
}
}
else {
+#ifdef PERL_MAD
+ OP* const oldo = o;
+#else
op_free(o);
+#endif
o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ op_getmad(oldo,o,'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,
+ (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
+ cUNOPo->op_first->op_sibling = hhop;
+ o->op_private |= OPpEVAL_HAS_HH;
+ }
return o;
}
Perl_ck_exit(pTHX_ OP *o)
{
#ifdef VMS
- HV *table = GvHV(PL_hintgv);
+ HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+ SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
OP *
Perl_ck_exists(pTHX_ OP *o)
{
+ dVAR;
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_ENTERSUB) {
(void) ref(kid, o->op_type);
if (kid->op_type != OP_RV2CV && !PL_error_count)
return o;
}
-#if 0
-OP *
-Perl_ck_gvconst(pTHX_ register OP *o)
-{
- o = fold_constants(o);
- if (o->op_type == OP_CONST)
- o->op_type = OP_GV;
- return o;
-}
-#endif
-
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ dVAR;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
+ if (o->op_type == OP_RV2CV)
+ o->op_private &= ~1;
+
if (kid->op_type == OP_CONST) {
int iscv;
GV *gv;
- SV *kidsv = kid->op_sv;
+ SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV *rsv = SvRV(kidsv);
- int svtype = SvTYPE(rsv);
- const char *badtype = Nullch;
+ SV * const rsv = SvRV(kidsv);
+ const int svtype = SvTYPE(rsv);
+ const char *badtype = NULL;
switch (o->op_type) {
case OP_RV2SV:
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
- if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
- const char *badthing = Nullch;
+ else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
+ (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
+ /* If this is an access to a stash, disable "strict refs", because
+ * stashes aren't auto-vivified at compile-time (unless we store
+ * symbols in them), and we don't want to produce a run-time
+ * stricture error when auto-vivifying the stash. */
+ const char *s = SvPV_nolen(kidsv);
+ const STRLEN l = SvCUR(kidsv);
+ if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
+ o->op_private &= ~HINT_STRICT_REFS;
+ }
+ if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
+ const char *badthing;
switch (o->op_type) {
case OP_RV2SV:
badthing = "a SCALAR";
case OP_RV2HV:
badthing = "a HASH";
break;
+ default:
+ badthing = NULL;
+ break;
}
if (badthing)
Perl_croak(aTHX_
kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
GvIN_PAD_on(gv);
- PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
+ PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
#else
- kid->op_sv = SvREFCNT_inc(gv);
+ kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
kid->op_private = 0;
kid->op_ppaddr = PL_ppaddr[OP_GV];
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
+ dVAR;
const I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
- /* nothing */
+ NOOP;
}
else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
-
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- OP *newop = newGVOP(type, OPf_REF,
- gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ const OPCODE kidtype = kid->op_type;
+
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ OP * const newop = newGVOP(type, OPf_REF,
+ gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
op_free(o);
- o = newop;
- return o;
+#endif
+ return newop;
}
- else {
- if ((PL_hints & HINT_FILETEST_ACCESS) &&
- OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
- }
- if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
- && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+ if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT)
o->op_private |= OPpFT_STACKED;
}
else {
+#ifdef PERL_MAD
+ OP* const oldo = o;
+#else
op_free(o);
+#endif
if (type == OP_FTTTY)
o = newGVOP(type, OPf_REF, PL_stdingv);
else
o = newUNOP(type, 0, newDEFSVOP());
+ op_getmad(oldo,o,'O');
}
return o;
}
OP *
Perl_ck_fun(pTHX_ OP *o)
{
+ dVAR;
const int type = o->op_type;
register I32 oa = PL_opargs[type] >> OASHIFT;
while (oa && kid) {
numargs++;
sibl = kid->op_sibling;
+#ifdef PERL_MAD
+ if (!sibl && kid->op_type == OP_STUB) {
+ numargs--;
+ break;
+ }
+#endif
switch (oa & 7) {
case OA_SCALAR:
/* list seen where single (scalar) arg expected? */
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
+ OP * const newop = newAVREF(newGVOP(OP_GV, 0,
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
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]);
+#ifdef PERL_MAD
+ op_getmad(kid,newop,'K');
+#else
op_free(kid);
+#endif
kid = newop;
kid->op_sibling = sibl;
*tokid = kid;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
+ OP * const newop = newHVREF(newGVOP(OP_GV, 0,
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
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]);
+#ifdef PERL_MAD
+ op_getmad(kid,newop,'K');
+#else
op_free(kid);
+#endif
kid = newop;
kid->op_sibling = sibl;
*tokid = kid;
break;
case OA_CVREF:
{
- OP *newop = newUNOP(OP_NULL, 0, kid);
+ OP * const newop = newUNOP(OP_NULL, 0, kid);
kid->op_sibling = 0;
linklist(kid);
newop->op_next = newop;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
+ OP * const newop = newGVOP(OP_GV, 0,
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
+#ifdef PERL_MAD
+ op_getmad(kid,newop,'K');
+#else
op_free(kid);
+#endif
kid = newop;
}
else if (kid->op_type == OP_READLINE) {
/* is this op a FH constructor? */
if (is_handle_constructor(o,numargs)) {
- const char *name = Nullch;
+ const char *name = NULL;
STRLEN len = 0;
flags = 0;
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(kUNOP->op_first);
+ GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
- OP *op;
-
- name = 0;
- if ((op = ((BINOP*)kid)->op_first)) {
- SV *tmpstr = Nullsv;
- const char *a =
+ OP *op = ((BINOP*)kid)->op_first;
+ name = NULL;
+ if (op) {
+ SV *tmpstr = NULL;
+ const char * const a =
kid->op_type == OP_AELEM ?
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op = ((UNOP*)op)->op_first) &&
(op->op_type == OP_GV)) {
/* packagevar $a[] or $h{} */
- GV *gv = cGVOPx_gv(op);
+ GV * const gv = cGVOPx_gv(op);
if (gv)
tmpstr =
Perl_newSVpvf(aTHX_
else if (op->op_type == OP_PADAV
|| op->op_type == OP_PADHV) {
/* lexicalvar $a[] or $h{} */
- const char *padname =
+ const char * const padname =
PAD_COMPNAME_PV(op->op_targ);
if (padname)
tmpstr =
"%s%c...%c",
padname + 1,
a[0], a[1]);
-
}
if (tmpstr) {
- name = SvPV(tmpstr, len);
+ name = SvPV_const(tmpstr, len);
sv_2mortal(tmpstr);
}
}
SV *namesv;
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
- (void)SvUPGRADE(namesv, SVt_PV);
+ SvUPGRADE(namesv, SVt_PV);
if (*name != '$')
sv_setpvn(namesv, "$", 1);
sv_catpvn(namesv, name, len);
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
+#ifdef PERL_MAD
+ if (kid && kid->op_type != OP_STUB)
+ return too_many_arguments(o,OP_DESC(o));
+ o->op_private |= numargs;
+#else
+ /* FIXME - should the numargs move as for the PERL_MAD case? */
o->op_private |= numargs;
if (kid)
return too_many_arguments(o,OP_DESC(o));
+#endif
listkids(o);
}
else if (PL_opargs[type] & OA_DEFGV) {
+#ifdef PERL_MAD
+ OP *newop = newUNOP(type, 0, newDEFSVOP());
+ op_getmad(o,newop,'O');
+ return newop;
+#else
+ /* Ordering of these two is important to keep f_map.t passing. */
op_free(o);
return newUNOP(type, 0, newDEFSVOP());
+#endif
}
if (oa) {
OP *
Perl_ck_glob(pTHX_ OP *o)
{
+ dVAR;
GV *gv;
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
- if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
+ if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
}
#if !defined(PERL_EXTERNAL_GLOB)
GV *glob_gv;
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
- glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
+ newSVpvs("File::Glob"), NULL, NULL, NULL);
+ gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
- (void)SvREFCNT_inc((SV*)GvCV(gv));
+ SvREFCNT_inc_void((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
LEAVE;
}
OP *
Perl_ck_grep(pTHX_ OP *o)
{
- LOGOP *gwop;
+ dVAR;
+ LOGOP *gwop = NULL;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- I32 offset;
+ PADOFFSET offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
- NewOp(1101, gwop, 1, LOGOP);
+ /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
if (o->op_flags & OPf_STACKED) {
OP* k;
o = ck_sort(o);
kid = cLISTOPo->op_first->op_sibling;
+ if (!cUNOPx(kid)->op_next)
+ Perl_croak(aTHX_ "panic: ck_grep");
for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
+ NewOp(1101, gwop, 1, LOGOP);
kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
Perl_croak(aTHX_ "panic: ck_grep");
kid = kUNOP->op_first;
+ if (!gwop)
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
gwop->op_first = listkids(o);
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
offset = pad_findmy("$_");
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
}
}
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;
+ if (0 == (o->op_flags & OPf_SPECIAL)) {
+ OP *first = cBINOPo->op_first;
+ OP *second = first->op_sibling;
+
+ /* Implicitly take a reference to an array or hash */
+ first->op_sibling = NULL;
+ first = cBINOPo->op_first = ref_array_or_hash(first);
+ second = first->op_sibling = ref_array_or_hash(second);
+
+ /* Implicitly take a reference to a regular expression */
+ if (first->op_type == OP_MATCH) {
+ first->op_type = OP_QR;
+ first->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ if (second->op_type == OP_MATCH) {
+ second->op_type = OP_QR;
+ second->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ }
+
+ return o;
+}
+
+
+OP *
Perl_ck_sassign(pTHX_ OP *o)
{
- OP *kid = cLISTOPo->op_first;
+ OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Cannot steal the second time! */
&& !(kid->op_private & OPpTARGET_MY))
{
- OP *kkid = kid->op_sibling;
+ OP * const kkid = kid->op_sibling;
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
/* Now we do not need PADSV and SASSIGN. */
kid->op_sibling = o->op_sibling; /* NULL */
cLISTOPo->op_first = NULL;
+#ifdef PERL_MAD
+ op_getmad(o,kid,'O');
+ op_getmad(kkid,kid,'M');
+#else
op_free(o);
op_free(kkid);
+#endif
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
- /* optimise C<my $x = undef> to C<my $x> */
- if (kid->op_type == OP_UNDEF) {
- OP *kkid = kid->op_sibling;
- if (kkid && kkid->op_type == OP_PADSV
- && (kkid->op_private & OPpLVAL_INTRO))
- {
- cLISTOPo->op_first = NULL;
- kid->op_sibling = NULL;
- op_free(o);
- op_free(kid);
- return kkid;
- }
- }
return o;
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- if (o->op_type != OP_QR) {
- const I32 offset = pad_findmy("$_");
- if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
+ dVAR;
+ if (o->op_type != OP_QR && PL_compcv) {
+ const PADOFFSET offset = pad_findmy("$_");
+ if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
}
OP *
Perl_ck_method(pTHX_ OP *o)
{
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
- if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
+ const char * const method = SvPVX_const(sv);
+ if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvCUR(sv), 0);
}
else {
- kSVOP->op_sv = Nullsv;
+ kSVOP->op_sv = NULL;
}
cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
+#ifdef PERL_MAD
+ op_getmad(o,cmop,'O');
+#else
op_free(o);
+#endif
return cmop;
}
}
OP *
Perl_ck_null(pTHX_ OP *o)
{
+ PERL_UNUSED_CONTEXT;
return o;
}
OP *
Perl_ck_open(pTHX_ OP *o)
{
- HV *table = GvHV(PL_hintgv);
+ dVAR;
+ HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp;
- I32 mode;
- svp = hv_fetch(table, "open_IN", 7, FALSE);
+ SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
- mode = mode_from_discipline(*svp);
+ const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
else if (mode & O_TEXT)
o->op_private |= OPpOPEN_IN_CRLF;
}
- svp = hv_fetch(table, "open_OUT", 8, FALSE);
+ svp = hv_fetchs(table, "open_OUT", FALSE);
if (svp && *svp) {
- mode = mode_from_discipline(*svp);
+ const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
else if (mode & O_TEXT)
{
/* In case of three-arg dup open remove strictness
* from the last arg if it is a bareword. */
- OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
- OP *last = cLISTOPx(o)->op_last; /* The bareword. */
+ OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
+ OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
OP *oa;
- char *mode;
+ const char *mode;
if ((last->op_type == OP_CONST) && /* The bareword. */
(last->op_private & OPpCONST_BARE) &&
(last->op_private & OPpCONST_STRICT) &&
(oa = first->op_sibling) && /* The fh. */
(oa = oa->op_sibling) && /* The mode. */
+ (oa->op_type == OP_CONST) &&
SvPOK(((SVOP*)oa)->op_sv) &&
- (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
+ (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
mode[0] == '>' && mode[1] == '&' && /* A dup open. */
(last == oa->op_sibling)) /* The bareword. */
last->op_private &= ~OPpCONST_STRICT;
OP *
Perl_ck_require(pTHX_ OP *o)
{
- GV* gv;
+ dVAR;
+ GV* gv = NULL;
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ SV * const sv = kid->op_sv;
+ U32 was_readonly = SvREADONLY(sv);
char *s;
- for (s = SvPVX(kid->op_sv); *s; s++) {
+
+ if (was_readonly) {
+ if (SvFAKE(sv)) {
+ sv_force_normal_flags(sv, 0);
+ assert(!SvREADONLY(sv));
+ was_readonly = 0;
+ } else {
+ SvREADONLY_off(sv);
+ }
+ }
+
+ for (s = SvPVX(sv); *s; s++) {
if (*s == ':' && s[1] == ':') {
+ const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, strlen(s+2)+1, char);
- --SvCUR(kid->op_sv);
+ Move(s+2, s+1, len, char);
+ SvCUR_set(sv, SvCUR(sv) - 1);
}
}
- if (SvREADONLY(kid->op_sv)) {
- SvREADONLY_off(kid->op_sv);
- sv_catpvn(kid->op_sv, ".pm", 3);
- SvREADONLY_on(kid->op_sv);
- }
- else
- sv_catpvn(kid->op_sv, ".pm", 3);
+ sv_catpvs(sv, ".pm");
+ SvFLAGS(sv) |= was_readonly;
}
}
- /* handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
+ if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
+ /* handle override, if any */
+ gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
+ gv = gvp ? *gvp : NULL;
+ }
+ }
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
+ OP * newop;
+
cUNOPo->op_first = 0;
+#ifndef PERL_MAD
op_free(o);
- return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+#endif
+ newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, kid,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0,
+ gv))))));
+ op_getmad(o,newop,'O');
+ return newop;
}
return ck_fun(o);
OP *
Perl_ck_return(pTHX_ OP *o)
{
+ dVAR;
if (CvLVALUE(PL_compcv)) {
OP *kid;
for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
return o;
}
-#if 0
-OP *
-Perl_ck_retarget(pTHX_ OP *o)
-{
- Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
- /* STUB */
- return o;
-}
-#endif
-
OP *
Perl_ck_select(pTHX_ OP *o)
{
+ dVAR;
OP* kid;
if (o->op_flags & OPf_KIDS) {
kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *
Perl_ck_shift(pTHX_ OP *o)
{
+ dVAR;
const I32 type = o->op_type;
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+ /* FIXME - this can be refactored to reduce code in #ifdefs */
+#ifdef PERL_MAD
+ OP * const oldo = o;
+#else
op_free(o);
+#endif
argop = newUNOP(OP_RV2AV, 0,
scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
+#ifdef PERL_MAD
+ o = newUNOP(type, 0, scalar(argop));
+ op_getmad(oldo,o,'O');
+ return o;
+#else
return newUNOP(type, 0, scalar(argop));
+#endif
}
return scalar(modkids(ck_fun(o), type));
}
OP *
Perl_ck_sort(pTHX_ OP *o)
{
+ dVAR;
OP *firstkid;
+ if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
+ HV * const hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
+ if (svp) {
+ const I32 sorthints = (I32)SvIV(*svp);
+ if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+ o->op_private |= OPpSORT_QSORT;
+ if ((sorthints & HINT_SORT_STABLE) != 0)
+ o->op_private |= OPpSORT_STABLE;
+ }
+ }
+ }
+
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
+ dVAR;
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int descending;
const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
- GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
- GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
+ GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
+ GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
if (kid->op_type != OP_SCOPE)
return;
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
kid = cLISTOPo->op_first->op_sibling;
cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
+#ifdef PERL_MAD
+ op_getmad(kid,o,'S'); /* then delete it */
+#else
op_free(kid); /* then delete it */
+#endif
}
OP *
Perl_ck_split(pTHX_ OP *o)
{
+ dVAR;
register OP *kid;
if (o->op_flags & OPf_STACKED)
op_free(cLISTOPo->op_first);
cLISTOPo->op_first = kid;
if (!kid) {
- cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
+ cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- OP *sibl = kid->op_sibling;
+ OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
kid->op_type = OP_PUSHRE;
kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
scalar(kid);
- if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+ if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
Perl_warner(aTHX_ packWARN(WARN_REGEXP),
"Use of /g modifier is meaningless in split");
}
if (!kid->op_sibling)
append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ assert(kid->op_sibling);
kid = kid->op_sibling;
scalar(kid);
OP *
Perl_ck_join(pTHX_ OP *o)
{
- if (ckWARN(WARN_SYNTAX)) {
- const OP *kid = cLISTOPo->op_first->op_sibling;
- if (kid && kid->op_type == OP_MATCH) {
+ const OP * const kid = cLISTOPo->op_first->op_sibling;
+ if (kid && kid->op_type == OP_MATCH) {
+ if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
const char *pmstr = re ? re->precomp : "STRING";
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
OP *
Perl_ck_subr(pTHX_ OP *o)
{
+ dVAR;
OP *prev = ((cUNOPo->op_first->op_sibling)
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
OP *cvop;
- char *proto = 0;
- CV *cv = 0;
- GV *namegv = 0;
+ const char *proto = NULL;
+ const char *proto_end = NULL;
+ CV *cv = NULL;
+ GV *namegv = NULL;
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e = 0;
- STRLEN n_a;
+ char *e = NULL;
bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
tmpop->op_private |= OPpEARLY_CV;
else {
if (SvPOK(cv)) {
+ STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, n_a);
+ proto = SvPV((SV*)cv, len);
+ proto_end = proto + len;
}
if (CvASSERTION(cv)) {
if (PL_hints & HINT_ASSERTING) {
}
else {
delete_op = 1;
- if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+ if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
"Impossible to activate assertion call");
}
if (o2->op_type == OP_CONST)
o2->op_private &= ~OPpCONST_STRICT;
else if (o2->op_type == OP_LIST) {
- OP *o = ((UNOP*)o2)->op_first->op_sibling;
- if (o && o->op_type == OP_CONST)
- o->op_private &= ~OPpCONST_STRICT;
+ OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
+ if (sib && sib->op_type == OP_CONST)
+ sib->op_private &= ~OPpCONST_STRICT;
}
}
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
+ OP* o3;
+ if (PL_madskills && o2->op_type == OP_NULL)
+ o3 = ((UNOP*)o2)->op_first;
+ else
+ o3 = o2;
if (proto) {
- switch (*proto) {
- case '\0':
+ if (proto >= proto_end)
return too_many_arguments(o, gv_ename(namegv));
+
+ switch (*proto) {
case ';':
optional = 1;
proto++;
case '&':
proto++;
arg++;
- if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
+ if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
bad_type(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o2);
+ gv_ename(namegv), o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
proto++;
arg++;
- if (o2->op_type == OP_RV2GV)
+ if (o3->op_type == OP_RV2GV)
goto wrapref; /* autoconvert GLOB -> GLOBref */
- else if (o2->op_type == OP_CONST)
- o2->op_private &= ~OPpCONST_STRICT;
- else if (o2->op_type == OP_ENTERSUB) {
+ else if (o3->op_type == OP_CONST)
+ o3->op_private &= ~OPpCONST_STRICT;
+ else if (o3->op_type == OP_ENTERSUB) {
/* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o2)->op_first;
+ OP *gvop = ((UNOP*)o3)->op_first;
if (gvop && gvop->op_type == OP_NULL) {
gvop = ((UNOP*)gvop)->op_first;
if (gvop) {
(gvop = ((UNOP*)gvop)->op_first) &&
gvop->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(gvop);
- OP *sibling = o2->op_sibling;
- SV *n = newSVpvn("",0);
+ GV * const gv = cGVOPx_gv(gvop);
+ OP * const sibling = o2->op_sibling;
+ SV * const n = newSVpvs("");
+#ifdef PERL_MAD
+ OP * const oldo2 = o2;
+#else
op_free(o2);
+#endif
gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
+ op_getmad(oldo2,o2,'O');
prev->op_sibling = o2;
o2->op_sibling = sibling;
}
break;
case ']':
if (contextclass) {
- char *p = proto;
- const char s = *p;
+ const char *p = proto;
+ const char *const end = proto;
contextclass = 0;
- *p = '\0';
while (*--p != '[');
- bad_type(arg, Perl_form(aTHX_ "one of %s", p),
- gv_ename(namegv), o2);
- *proto = s;
+ bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ (int)(end - p), p),
+ gv_ename(namegv), o3);
} else
goto oops;
break;
case '*':
- if (o2->op_type == OP_RV2GV)
+ if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o2);
+ bad_type(arg, "symbol", gv_ename(namegv), o3);
break;
case '&':
- if (o2->op_type == OP_ENTERSUB)
+ if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+ bad_type(arg, "subroutine entry", gv_ename(namegv),
+ o3);
break;
case '$':
- if (o2->op_type == OP_RV2SV ||
- o2->op_type == OP_PADSV ||
- o2->op_type == OP_HELEM ||
- o2->op_type == OP_AELEM ||
- o2->op_type == OP_THREADSV)
+ 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)
goto wrapref;
if (!contextclass)
- bad_type(arg, "scalar", gv_ename(namegv), o2);
+ bad_type(arg, "scalar", gv_ename(namegv), o3);
break;
case '@':
- if (o2->op_type == OP_RV2AV ||
- o2->op_type == OP_PADAV)
+ if (o3->op_type == OP_RV2AV ||
+ o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o2);
+ bad_type(arg, "array", gv_ename(namegv), o3);
break;
case '%':
- if (o2->op_type == OP_RV2HV ||
- o2->op_type == OP_PADHV)
+ if (o3->op_type == OP_RV2HV ||
+ o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o2);
+ bad_type(arg, "hash", gv_ename(namegv), o3);
break;
wrapref:
{
- OP* kid = o2;
- OP* sib = kid->op_sibling;
+ OP* const kid = o2;
+ OP* const sib = kid->op_sibling;
kid->op_sibling = 0;
o2 = newUNOP(OP_REFGEN, 0, kid);
o2->op_sibling = sib;
mod(o2, OP_ENTERSUB);
prev = o2;
o2 = o2->op_sibling;
- }
- if (proto && !optional &&
- (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ } /* while */
+ if (proto && !optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
+#ifdef PERL_MAD
+ OP * const oldo = o;
+#else
op_free(o);
+#endif
o=newSVOP(OP_CONST, 0, newSViv(0));
+ op_getmad(oldo,o,'O');
}
return o;
}
OP *
Perl_ck_svconst(pTHX_ OP *o)
{
+ PERL_UNUSED_CONTEXT;
SvREADONLY_on(cSVOPo->op_sv);
return o;
}
OP *
+Perl_ck_chdir(pTHX_ OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
+
+ if (kid && kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE))
+ {
+ o->op_flags |= OPf_SPECIAL;
+ kid->op_private &= ~OPpCONST_STRICT;
+ }
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_trunc(pTHX_ OP *o)
{
if (o->op_flags & OPf_KIDS) {
Perl_ck_substr(pTHX_ OP *o)
{
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
+ if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
void
Perl_peep(pTHX_ register OP *o)
{
- register OP* oldop = 0;
+ dVAR;
+ register OP* oldop = NULL;
if (!o || o->op_opt)
return;
SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
+ else if (o->op_type == OP_CONST
+ && cSVOPo->op_sv == &PL_sv_undef) {
+ /* PL_sv_undef is hack - it's unsafe to store it in the
+ AV that is the pad, because av_fetch treats values of
+ PL_sv_undef as a "free" AV entry and will merrily
+ replace them with a new SV, causing pad_alloc to think
+ that this pad slot is free. (When, clearly, it is not)
+ */
+ SvOK_off(PAD_SVl(ix));
+ SvPADTMP_on(PAD_SVl(ix));
+ SvREADONLY_on(PAD_SVl(ix));
+ }
else {
SvREFCNT_dec(PAD_SVl(ix));
SvPADTMP_on(cSVOPo->op_sv);
/* XXX I don't know how this isn't readonly already. */
SvREADONLY_on(PAD_SVl(ix));
}
- cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_sv = NULL;
o->op_targ = ix;
}
#endif
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
- OP* pop = (o->op_type == OP_PADAV) ?
+ OP* const pop = (o->op_type == OP_PADAV) ?
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
+ (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
<= 255 &&
i >= 0)
{
}
}
else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV *gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
+ GV * const gv = cGVOPo_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
/* XXX could check prototype here instead of just carping */
- SV *sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
+ SV * const sv = sv_newmortal();
+ gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
sv);
case OP_EXEC:
o->op_opt = 1;
- if (ckWARN(WARN_SYNTAX) && o->op_next
- && o->op_next->op_type == OP_NEXTSTATE) {
- if (o->op_next->op_sibling &&
- o->op_next->op_sibling->op_type != OP_EXIT &&
- o->op_next->op_sibling->op_type != OP_WARN &&
- o->op_next->op_sibling->op_type != OP_DIE) {
- const line_t oldline = CopLINE(PL_curcop);
-
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "Statement unlikely to be reached");
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "\t(Maybe you meant system() when you said exec()?)\n");
- CopLINE_set(PL_curcop, oldline);
+ if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
+ && ckWARN(WARN_SYNTAX))
+ {
+ if (o->op_next->op_sibling) {
+ const OPCODE type = o->op_next->op_sibling->op_type;
+ if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
+ const line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "Statement unlikely to be reached");
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "\t(Maybe you meant system() when you said exec()?)\n");
+ CopLINE_set(PL_curcop, oldline);
+ }
}
}
break;
SV *lexname;
GV **fields;
SV **svp, *sv;
- char *key = NULL;
+ const char *key = NULL;
STRLEN keylen;
o->op_opt = 1;
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
- key = SvPV(sv, keylen);
+ key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : keylen,
+ SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
0);
SvREFCNT_dec(sv);
*svp = lexname;
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
+ if (!SvPAD_TYPED(lexname))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
- key = SvPV(*svp, keylen);
+ key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
}
break;
SV *lexname;
GV **fields;
SV **svp;
- char *key;
+ const char *key;
STRLEN keylen;
SVOP *first_key_op, *key_op;
}
lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
+ if (!SvPAD_TYPED(lexname))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
/* Again guessing that the pushmark can be jumped over.... */
if (key_op->op_type != OP_CONST)
continue;
svp = cSVOPx_svp(key_op);
- key = SvPV(*svp, keylen);
+ key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
}
}
break;
case OP_SORT: {
/* will point to RV2AV or PADAV op on LHS/RHS of assign */
- OP *oleft, *oright;
+ OP *oleft;
OP *o2;
/* check that RHS of sort is a single plain array */
- oright = cUNOPo->op_first;
+ OP *oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
/* reverse sort ... can be optimised. */
if (!cUNOPo->op_sibling) {
/* Nothing follows us on the list. */
- OP *reverse = o->op_next;
+ OP * const reverse = o->op_next;
if (reverse->op_type == OP_REVERSE &&
(reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
- OP *pushmark = cUNOPx(reverse)->op_first;
+ OP * const pushmark = cUNOPx(reverse)->op_first;
if (pushmark && (pushmark->op_type == OP_PUSHMARK)
&& (cUNOPx(pushmark)->op_sibling == o)) {
/* reverse -> pushmark -> sort */
break;
}
+
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ /* I do not understand this, but if o->op_opt isn't set to 1,
+ various tests in ext/B/t/bytecode.t fail with no readily
+ apparent cause. */
+
+ o->op_opt = 1;
+
+
+ if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
+ break;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
default:
o->op_opt = 1;
char*
Perl_custom_op_name(pTHX_ const OP* o)
{
+ dVAR;
const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
if (!PL_custom_op_names) /* This probably shouldn't happen */
- return PL_op_name[OP_CUSTOM];
+ return (char *)PL_op_name[OP_CUSTOM];
keysv = sv_2mortal(newSViv(index));
he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
if (!he)
- return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+ return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
return SvPV_nolen(HeVAL(he));
}
char*
Perl_custom_op_desc(pTHX_ const OP* o)
{
+ dVAR;
const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
if (!PL_custom_op_descs)
- return PL_op_desc[OP_CUSTOM];
+ return (char *)PL_op_desc[OP_CUSTOM];
keysv = sv_2mortal(newSViv(index));
he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
if (!he)
- return PL_op_desc[OP_CUSTOM];
+ return (char *)PL_op_desc[OP_CUSTOM];
return SvPV_nolen(HeVAL(he));
}
static void
const_sv_xsub(pTHX_ CV* cv)
{
+ dVAR;
dXSARGS;
if (items != 0) {
+ NOOP;
#if 0
Perl_croak(aTHX_ "usage: %s::%s()",
- HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
+ HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
#endif
}
EXTEND(sp, 1);
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */