/* op.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
*/
/*
- * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
- * our Mr. Bilbo's first cousin on the mother's side (her mother being the
- * youngest of the Old Took's daughters); and Mr. Drogo was his second
- * cousin. So Mr. Frodo is his first *and* second cousin, once removed
- * either way, as the saying is, if you follow me." --the Gaffer
+ * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
+ * our Mr. Bilbo's first cousin on the mother's side (her mother being the
+ * youngest of the Old Took's daughters); and Mr. Drogo was his second
+ * cousin. So Mr. Frodo is his first *and* second cousin, once removed
+ * either way, as the saying is, if you follow me.' --the Gaffer
+ *
+ * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* This file contains the functions that create, manipulate and optimize
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_hash> with a store
- record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
it will be correctly restored when any inner compiling scope is exited.
*/
#if defined(PL_OP_SLAB_ALLOC)
+#ifdef PERL_DEBUG_READONLY_OPS
+# define PERL_SLAB_SIZE 4096
+# include <sys/mman.h>
+#endif
+
#ifndef PERL_SLAB_SIZE
#define PERL_SLAB_SIZE 2048
#endif
void *
-Perl_Slab_Alloc(pTHX_ int m, size_t sz)
+Perl_Slab_Alloc(pTHX_ size_t sz)
{
+ dVAR;
/*
* To make incrementing use count easy PL_OpSlab is an I32 *
* To make inserting the link to slab PL_OpPtr is I32 **
*/
sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
if ((PL_OpSpace -= sz) < 0) {
- PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* We need to allocate chunk by chunk so that we can control the VM
+ mapping */
+ PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0);
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
+ (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
+ PL_OpPtr));
+ if(PL_OpPtr == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+#else
+
+ PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
+#endif
if (!PL_OpPtr) {
return NULL;
}
- Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
/* We reserve the 0'th I32 sized chunk as a use count */
PL_OpSlab = (I32 *) PL_OpPtr;
/* Reduce size by the use count word, and by the size we need.
means that at run time access is cache friendly upward
*/
PL_OpPtr += PERL_SLAB_SIZE;
+
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* We remember this slab. */
+ /* This implementation isn't efficient, but it is simple. */
+ PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
+ PL_slabs[PL_slab_count++] = PL_OpSlab;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
+#endif
}
assert( PL_OpSpace >= 0 );
/* Move the allocation pointer down */
return (void *)(PL_OpPtr + 1);
}
+#ifdef PERL_DEBUG_READONLY_OPS
+void
+Perl_pending_Slabs_to_ro(pTHX) {
+ /* Turn all the allocated op slabs read only. */
+ U32 count = PL_slab_count;
+ I32 **const slabs = PL_slabs;
+
+ /* Reset the array of pending OP slabs, as we're about to turn this lot
+ read only. Also, do it ahead of the loop in case the warn triggers,
+ and a warn handler has an eval */
+
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+
+ /* Force a new slab for any further allocation. */
+ PL_OpSpace = 0;
+
+ while (count--) {
+ void *const start = slabs[count];
+ const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
+ if(mprotect(start, size, PROT_READ)) {
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
+ start, (unsigned long) size, errno);
+ }
+ }
+
+ free(slabs);
+}
+
+STATIC void
+S_Slab_to_rw(pTHX_ void *op)
+{
+ I32 * const * const ptr = (I32 **) op;
+ I32 * const slab = ptr[-1];
+
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
+
+ assert( ptr-1 > (I32 **) slab );
+ assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+ assert( *slab > 0 );
+ if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
+ slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
+ }
+}
+
+OP *
+Perl_op_refcnt_inc(pTHX_ OP *o)
+{
+ if(o) {
+ Slab_to_rw(o);
+ ++o->op_targ;
+ }
+ return o;
+
+}
+
+PADOFFSET
+Perl_op_refcnt_dec(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_OP_REFCNT_DEC;
+ Slab_to_rw(o);
+ return --o->op_targ;
+}
+#else
+# define Slab_to_rw(op)
+#endif
+
void
Perl_Slab_Free(pTHX_ void *op)
{
I32 * const * const ptr = (I32 **) op;
I32 * const slab = ptr[-1];
+ PERL_ARGS_ASSERT_SLAB_FREE;
assert( ptr-1 > (I32 **) slab );
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
+ Slab_to_rw(op);
if (--(*slab) == 0) {
# ifdef NETWARE
# define PerlMemShared PerlMem
# endif
+#ifdef PERL_DEBUG_READONLY_OPS
+ U32 count = PL_slab_count;
+ /* Need to remove this slab from our list of slabs */
+ if (count) {
+ while (count--) {
+ if (PL_slabs[count] == slab) {
+ dVAR;
+ /* Found it. Move the entry at the end to overwrite it. */
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "Deallocate %p by moving %p from %lu to %lu\n",
+ PL_OpSlab,
+ PL_slabs[PL_slab_count - 1],
+ PL_slab_count, count));
+ PL_slabs[count] = PL_slabs[--PL_slab_count];
+ /* Could realloc smaller at this point, but probably not
+ worth it. */
+ if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
+ perror("munmap failed");
+ abort();
+ }
+ break;
+ }
+ }
+ }
+#else
PerlMemShared_free(slab);
+#endif
if (slab == PL_OpSlab) {
PL_OpSpace = 0;
}
S_gv_ename(pTHX_ GV *gv)
{
SV* const tmpsv = sv_newmortal();
+
+ PERL_ARGS_ASSERT_GV_ENAME;
+
gv_efullname3(tmpsv, gv, NULL);
return SvPV_nolen_const(tmpsv);
}
STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_NO_FH_ALLOWED;
+
yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
OP_DESC(o)));
return o;
STATIC OP *
S_too_few_arguments(pTHX_ OP *o, const char *name)
{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+
yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
return o;
}
STATIC OP *
S_too_many_arguments(pTHX_ OP *o, const char *name)
{
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+
yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
return o;
}
STATIC void
S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
{
+ PERL_ARGS_ASSERT_BAD_TYPE;
+
yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
(int)n, name, t, OP_DESC(kid)));
}
STATIC void
S_no_bareword_allowed(pTHX_ const OP *o)
{
+ PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
+
if (PL_madskills)
return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
{
dVAR;
PADOFFSET off;
- const bool is_our = (PL_in_my == KEY_our);
+ const bool is_our = (PL_parser->in_my == KEY_our);
+
+ PERL_ARGS_ASSERT_ALLOCMY;
/* complain about "my $<special_var>" etc etc */
if (*name &&
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
- name[0], toCTRL(name[1]), name + 2));
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
+ name[0], toCTRL(name[1]), name + 2,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
/* check for duplicate declaration */
pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
- if (PL_in_my_stash && *name != '$') {
+ if (PL_parser->in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
name,
- is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ is_our ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
}
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
- PL_in_my_stash,
+ PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
),
0, /* not fake */
- PL_in_my == KEY_state
+ PL_parser->in_my == KEY_state
);
+ /* anon sub prototypes contains state vars should always be cloned,
+ * otherwise the state var would be shared between anon subs */
+
+ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
+ CvCLONE_on(PL_compcv);
+
return off;
}
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
-void
+static void
S_op_destroy(pTHX_ OP *o)
{
if (o->op_latefree) {
FreeOp(o);
}
+#ifdef USE_ITHREADS
+# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
+#else
+# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
+#endif
/* Destructor */
dVAR;
OPCODE type;
- if (!o || o->op_static)
+ if (!o)
return;
if (o->op_latefreed) {
if (o->op_latefree)
OP_REFCNT_LOCK;
refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
- if (refcnt)
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
return;
}
+ }
break;
default:
break;
op_free(kid);
}
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
+
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(o);
+#endif
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE
+ || (type == OP_NULL /* the COP might have been null'ed */
+ && ((OPCODE)o->op_targ == OP_NEXTSTATE
+ || (OPCODE)o->op_targ == OP_DBSTATE))) {
cop_free((COP*)o);
+ }
+
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
op_clear(o);
if (o->op_latefree) {
{
dVAR;
+
+ PERL_ARGS_ASSERT_OP_CLEAR;
+
#ifdef PERL_MAD
/* if (o->op_madprop && o->op_madprop->mad_next)
abort(); */
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_type = (Optype)o->op_targ;
o->op_targ = 0;
goto retry;
}
break;
case OP_METHOD_NAMED:
case OP_CONST:
+ case OP_HINTSEVAL:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#ifdef USE_ITHREADS
}
break;
case OP_SUBST:
- op_free(cPMOPo->op_pmreplroot);
+ op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
goto clear_pmop;
case OP_PUSHRE:
#ifdef USE_ITHREADS
- if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
+ if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
/* No GvIN_PAD_off here, because other references may still
* exist on the pad */
- pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
+ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
- SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
+ SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
/* FALL THROUGH */
case OP_MATCH:
case OP_QR:
clear_pmop:
- {
- HV * const pmstash = PmopSTASH(cPMOPo);
- if (pmstash && !SvIS_FREED(pmstash)) {
- MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
- if (mg) {
- PMOP *pmop = (PMOP*) mg->mg_obj;
- PMOP *lastpmop = NULL;
- while (pmop) {
- if (cPMOPo == pmop) {
- if (lastpmop)
- lastpmop->op_pmnext = pmop->op_pmnext;
- else
- mg->mg_obj = (SV*) pmop->op_pmnext;
- break;
- }
- lastpmop = pmop;
- pmop = pmop->op_pmnext;
- }
- }
- }
- PmopSTASH_free(cPMOPo);
- }
- cPMOPo->op_pmreplroot = NULL;
- /* we use the "SAFE" version of the PM_ macros here
- * since sv_clean_all might release some PMOPs
+ forget_pmop(cPMOPo, 1);
+ cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
+ /* we use the same protection as the "SAFE" version of the PM_ macros
+ * here since sv_clean_all might release some PMOPs
* after PL_regex_padav has been cleared
* and the clearing of PL_regex_padav needs to
* happen before sv_clean_all
*/
- ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
- 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]);
- SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
- PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
+ const IV offset = (cPMOPo)->op_pmoffset;
+ ReREFCNT_dec(PM_GETRE(cPMOPo));
+ PL_regex_pad[offset] = &PL_sv_undef;
+ sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
+ sizeof(offset));
}
+#else
+ ReREFCNT_dec(PM_GETRE(cPMOPo));
+ PM_SETRE(cPMOPo, NULL);
#endif
break;
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- CopLABEL_free(cop);
+ PERL_ARGS_ASSERT_COP_FREE;
+
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
+STATIC void
+S_forget_pmop(pTHX_ PMOP *const o
+#ifdef USE_ITHREADS
+ , U32 flags
+#endif
+ )
+{
+ HV * const pmstash = PmopSTASH(o);
+
+ PERL_ARGS_ASSERT_FORGET_PMOP;
+
+ if (pmstash && !SvIS_FREED(pmstash)) {
+ MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP **const array = (PMOP**) mg->mg_ptr;
+ U32 count = mg->mg_len / sizeof(PMOP**);
+ U32 i = count;
+
+ while (i--) {
+ if (array[i] == o) {
+ /* Found it. Move the entry at the end to overwrite it. */
+ array[i] = array[--count];
+ mg->mg_len = count * sizeof(PMOP**);
+ /* Could realloc smaller at this point always, but probably
+ not worth it. Probably worth free()ing if we're the
+ last. */
+ if(!count) {
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ }
+ break;
+ }
+ }
+ }
+ }
+ if (PL_curpm == o)
+ PL_curpm = NULL;
+#ifdef USE_ITHREADS
+ if (flags)
+ PmopSTASH_free(o);
+#endif
+}
+
+STATIC void
+S_find_and_forget_pmops(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ while (kid) {
+ switch (kid->op_type) {
+ case OP_SUBST:
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_QR:
+ forget_pmop((PMOP*)kid, 0);
+ }
+ find_and_forget_pmops(kid);
+ kid = kid->op_sibling;
+ }
+ }
+}
+
void
Perl_op_null(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OP_NULL;
+
if (o->op_type == OP_NULL)
return;
if (!PL_madskills)
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
-OP *
-Perl_linklist(pTHX_ OP *o)
+static OP *
+S_linklist(pTHX_ OP *o)
{
OP *first;
+ PERL_ARGS_ASSERT_LINKLIST;
+
if (o->op_next)
return o->op_next;
return o->op_next;
}
-OP *
-Perl_scalarkids(pTHX_ OP *o)
+static OP *
+S_scalarkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
S_scalarboolean(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SCALARBOOLEAN;
+
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
OP *kid;
/* assumes no premature commitment */
- if (!o || PL_error_count || (o->op_flags & OPf_WANT)
+ if (!o || (PL_parser && PL_parser->error_count)
+ || (o->op_flags & OPf_WANT)
|| o->op_type == OP_RETURN)
{
return o;
break;
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplroot)
+ if (!kPMOP->op_pmreplrootu.op_pmreplroot)
deprecate_old("implicit split to @_");
}
/* FALL THROUGH */
case OP_SORT:
if (ckWARN(WARN_VOID))
Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
}
return o;
}
SV* sv;
U8 want;
+ PERL_ARGS_ASSERT_SCALARVOID;
+
/* trailing mad null ops don't count as "there" for void processing */
if (PL_madskills &&
o->op_type != OP_NULL &&
}
if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_SETSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_SETSTATE
|| o->op_targ == OP_DBSTATE)))
PL_curcop = (COP*)o; /* for warning below */
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR) || PL_error_count
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN)
{
return o;
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
+ case OP_SMARTMATCH:
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
case OP_PROTOTYPE:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
useless = OP_DESC(o);
break;
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- useless = "a constant";
+ if (SvOK(sv)) {
+ SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+ "a constant (%"SVf")", sv));
+ useless = SvPV_nolen(msv);
+ }
+ else
+ useless = "a constant (undef)";
if (o->op_private & OPpCONST_ARYBASE)
useless = NULL;
/* don't warn on optimised away booleans, eg
case OP_OR:
case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)
+ && !PL_madskills) {
+ if (o->op_type == OP_AND) {
+ o->op_type = OP_OR;
+ o->op_ppaddr = PL_ppaddr[OP_OR];
+ } else {
+ o->op_type = OP_AND;
+ o->op_ppaddr = PL_ppaddr[OP_AND];
+ }
+ op_null(kid);
+ }
+
case OP_DOR:
case OP_COND_EXPR:
case OP_ENTERGIVEN:
return scalar(o);
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplroot)
+ if (!kPMOP->op_pmreplrootu.op_pmreplroot)
deprecate_old("implicit split to @_");
}
break;
return o;
}
-OP *
-Perl_listkids(pTHX_ OP *o)
+static OP *
+S_listkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
OP *kid;
/* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ if (!o || (o->op_flags & OPf_WANT)
+ || (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN)
{
return o;
return o;
}
-OP *
-Perl_scalarseq(pTHX_ OP *o)
+static OP *
+S_scalarseq(pTHX_ OP *o)
{
dVAR;
if (o) {
/* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
int localize = -1;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
if ((o->op_private & OPpTARGET_MY)
Perl_croak(aTHX_ "That use of $[ is unsupported");
break;
case OP_STUB:
- if (o->op_flags & OPf_PARENS || PL_madskills)
+ if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
+ PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
+
switch (type) {
case OP_SASSIGN:
if (o->op_type == OP_RV2GV)
case OP_RECV:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
return TRUE;
default:
return FALSE;
STATIC bool
S_is_handle_constructor(const OP *o, I32 numargs)
{
+ PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
+
switch (o->op_type) {
case OP_PIPE_OP:
case OP_SOCKPAIR:
}
}
-OP *
-Perl_refkids(pTHX_ OP *o, I32 type)
+static OP *
+S_refkids(pTHX_ OP *o, I32 type)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
dVAR;
OP *kid;
- if (!o || PL_error_count)
+ PERL_ARGS_ASSERT_DOREF;
+
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
switch (o->op_type) {
dVAR;
OP *rop;
+ PERL_ARGS_ASSERT_DUP_ATTRLIST;
+
/* 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.
dVAR;
SV *stashsv;
+ PERL_ARGS_ASSERT_APPLY_ATTRS;
+
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
- SAVEINT(PL_expect);
stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
OP *pack, *imop, *arg;
SV *meth, *stashsv;
+ PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
+
if (!attrs)
return;
{
OP *attrs = NULL;
+ PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
+
if (!len) {
len = strlen(attrstr);
}
newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0,
- newRV((SV*)cv)),
+ newRV(MUTABLE_SV(cv))),
attrs)));
}
dVAR;
I32 type;
- if (!o || PL_error_count)
+ PERL_ARGS_ASSERT_MY_KID;
+
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
type = o->op_type;
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? (SV*)GvAV(gv) :
- type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+ type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
+ type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
attrs, FALSE);
}
o->op_private |= OPpOUR_INTRO;
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state ? "state" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
/* check for C<my Dog $spot> when deciding package */
stash = PAD_COMPNAME_TYPE(o->op_targ);
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
- if (PL_in_my == KEY_state)
+ if (PL_parser->in_my == KEY_state)
o->op_private |= OPpPAD_STATE;
return o;
}
OP *rops;
int maybe_scalar = 0;
+ PERL_ARGS_ASSERT_MY_ATTRS;
+
/* [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
else
o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
}
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
return o;
}
OP *
-Perl_my(pTHX_ OP *o)
-{
- return my_attrs(o, NULL);
-}
-
-OP *
Perl_sawparens(pTHX_ OP *o)
{
PERL_UNUSED_CONTEXT;
const OPCODE ltype = left->op_type;
const OPCODE rtype = right->op_type;
+ PERL_ARGS_ASSERT_BIND_MATCH;
+
if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
|| ltype == OP_PADHV) && ckWARN(WARN_MISC))
{
Perl_newPROG(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWPROG;
+
if (PL_in_eval) {
if (PL_eval_root)
return;
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv
- = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
- XPUSHs((SV*)CopFILEGV(&PL_compiling));
+ XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
}
}
}
Perl_localize(pTHX_ OP *o, I32 lex)
{
dVAR;
+
+ PERL_ARGS_ASSERT_LOCALIZE;
+
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 */
NOOP;
#endif
else {
- if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+ if ( PL_parser->bufptr > PL_parser->oldbufptr
+ && PL_parser->bufptr[-1] == ','
&& ckWARN(WARN_PARENTHESIS))
{
- char *s = PL_bufptr;
+ char *s = PL_parser->bufptr;
bool sigil = FALSE;
/* some heuristics to detect a potential error */
if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
- : "local");
+ lex
+ ? (PL_parser->in_my == KEY_our
+ ? "our"
+ : PL_parser->in_my == KEY_state
+ ? "state"
+ : "my")
+ : "local");
}
}
}
o = my(o);
else
o = mod(o, OP_NULL); /* a bit kludgey */
- PL_in_my = FALSE;
- PL_in_my_stash = NULL;
+ PL_parser->in_my = FALSE;
+ PL_parser->in_my_stash = NULL;
return o;
}
OP *
Perl_jmaybe(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_JMAYBE;
+
if (o->op_type == OP_LIST) {
OP * const o2
= newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
return o;
}
-OP *
-Perl_fold_constants(pTHX_ register OP *o)
+static OP *
+S_fold_constants(pTHX_ register OP *o)
{
dVAR;
- register OP *curop;
+ register OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
+ COP not_compiling;
dJMPENV;
+ PERL_ARGS_ASSERT_FOLD_CONSTANTS;
+
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET && !o->op_targ)
/* XXX what about the numeric ops? */
if (PL_hints & HINT_LOCALE)
goto nope;
+ break;
}
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ /* Verify that we don't need to save it: */
+ assert(PL_curcop == &PL_compiling);
+ StructCopy(&PL_compiling, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
JMPENV_PUSH(ret);
case 3:
/* Something tried to die. Abandon constant folding. */
/* Pretend the error never happened. */
- sv_setpvn(ERRSV,"",0);
+ CLEAR_ERRSV();
o->op_next = old_next;
break;
default:
JMPENV_POP;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
+ PL_curcop = &PL_compiling;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
#endif
assert(sv);
if (type == OP_RV2GV)
- newop = newGVOP(OP_GV, 0, (GV*)sv);
+ newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, 0, (SV*)sv);
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
op_getmad(o,newop,'f');
return newop;
return o;
}
-OP *
-Perl_gen_constant_list(pTHX_ register OP *o)
+static OP *
+S_gen_constant_list(pTHX_ register OP *o)
{
dVAR;
register OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
list(o);
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
PL_op = curop = LINKLIST(o);
void
Perl_token_free(pTHX_ TOKEN* tk)
{
+ PERL_ARGS_ASSERT_TOKEN_FREE;
+
if (tk->tk_type != 12345)
return;
mad_free(tk->tk_mad);
{
MADPROP* mp;
MADPROP* tm;
+
+ PERL_ARGS_ASSERT_TOKEN_GETMAD;
+
if (tk->tk_type != 12345) {
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Invalid TOKEN object ignored");
/* faked up qw list? */
if (slot == '(' &&
tm->mad_type == MAD_SV &&
- SvPVX((SV*)tm->mad_val)[0] == 'q')
+ SvPVX((const SV *)tm->mad_val)[0] == 'q')
slot = 'x';
if (o) {
MADPROP *
Perl_newMADsv(pTHX_ char key, SV* sv)
{
+ PERL_ARGS_ASSERT_NEWMADSV;
+
return newMADPROP(key, MAD_SV, sv, 0);
}
MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
{
MADPROP *mp;
Newxz(mp, 1, MADPROP);
return;
if (mp->mad_next)
mad_free(mp->mad_next);
-/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
+/* if (PL_parser && PL_parser->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:
op_free((OP*)mp->mad_val);
break;
case MAD_SV:
- sv_free((SV*)mp->mad_val);
+ sv_free(MUTABLE_SV(mp->mad_val));
break;
default:
PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
return newOP(OP_STUB, 0);
}
-OP *
-Perl_force_list(pTHX_ OP *o)
+static OP *
+S_force_list(pTHX_ OP *o)
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
return 0;
}
-OP *
-Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
+static OP *
+S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
I32 del = o->op_private & OPpTRANS_DELETE;
SV* swash;
+
+ PERL_ARGS_ASSERT_PMTRANS;
+
PL_hints |= HINT_BLOCK_SCOPE;
if (SvUTF8(tstr))
PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
- swash = (SV*)swash_init("utf8", "", listsv, bits, none);
+ swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
SvREFCNT_dec(transv);
if (!del && havefinal && rlen)
- (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
+ (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
if (grows)
}
}
}
+
+ if(ckWARN(WARN_MISC)) {
+ if(del && rlen == tlen) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
+ } else if(rlen > tlen) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
+ }
+ }
+
if (grows)
o->op_private |= OPpTRANS_GROWS;
#ifdef PERL_MAD
pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_hints & HINT_RE_TAINT)
- pmop->op_pmpermflags |= PMf_RETAINT;
+ pmop->op_pmflags |= PMf_RETAINT;
if (PL_hints & HINT_LOCALE)
- pmop->op_pmpermflags |= PMf_LOCALE;
- pmop->op_pmflags = pmop->op_pmpermflags;
+ pmop->op_pmflags |= PMf_LOCALE;
+
#ifdef USE_ITHREADS
- if (av_len((AV*) PL_regex_pad[0]) > -1) {
- SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
- pmop->op_pmoffset = SvIV(repointer);
- SvREPADTMP_off(repointer);
- sv_setiv(repointer,0);
+ assert(SvPOK(PL_regex_pad[0]));
+ if (SvCUR(PL_regex_pad[0])) {
+ /* Pop off the "packed" IV from the end. */
+ SV *const repointer_list = PL_regex_pad[0];
+ const char *p = SvEND(repointer_list) - sizeof(IV);
+ const IV offset = *((IV*)p);
+
+ assert(SvCUR(repointer_list) % sizeof(IV) == 0);
+
+ SvEND_set(repointer_list, p);
+
+ pmop->op_pmoffset = offset;
+ /* This slot should be free, so assert this: */
+ assert(PL_regex_pad[offset] == &PL_sv_undef);
} else {
- SV * const repointer = newSViv(0);
- av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
+ SV * const repointer = &PL_sv_undef;
+ av_push(PL_regex_padav, 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) {
- MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
-
- if (!mg) {
- mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
- }
- pmop->op_pmnext = (PMOP*)mg->mg_obj;
- mg->mg_obj = (SV*)pmop;
- PmopSTASH_set(pmop,PL_curstash);
- }
-
return CHECKOP(type, pmop);
}
OP* repl = NULL;
bool reglist;
+ PERL_ARGS_ASSERT_PMRUNTIME;
+
if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
/* last element in list is the replacement; pop it */
OP* kid;
pm = (PMOP*)o;
if (expr->op_type == OP_CONST) {
- STRLEN plen;
- SV * const pat = ((SVOP*)expr)->op_sv;
- const char *p = SvPV_const(pat, plen);
- if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
- 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);
+ SV *pat = ((SVOP*)expr)->op_sv;
+ U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+
+ if (o->op_flags & OPf_SPECIAL)
+ pm_flags |= RXf_SPLIT;
+
+ if (DO_UTF8(pat)) {
+ assert (SvUTF8(pat));
+ } else if (SvUTF8(pat)) {
+ /* Not doing UTF-8, despite what the SV says. Is this only if we're
+ trapped in use 'bytes'? */
+ /* Make a copy of the octet sequence, but without the flag on, as
+ the compiler now honours the SvUTF8 flag on pat. */
+ STRLEN len;
+ const char *const p = SvPV(pat, len);
+ pat = newSVpvn_flags(p, len, SVs_TEMP);
+ }
- SvFLAGS(pat) |= was_readonly;
+ PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
- p = SvPV_const(pat, plen);
- pm->op_pmflags |= PMf_SKIPWHITE;
- }
- if (DO_UTF8(pat))
- pm->op_pmdynflags |= PMdf_UTF8;
- /* FIXME - can we make this function take const char * args? */
- PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
- if (PM_GETRE(pm)->extflags & RXf_WHITE)
- pm->op_pmflags |= PMf_WHITE;
- else
- pm->op_pmflags &= ~PMf_WHITE;
#ifdef PERL_MAD
op_getmad(expr,(OP*)pm,'e');
#else
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
curop = NULL;
- if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
- CopLINE_set(PL_curcop, (line_t)PL_multi_end);
+ if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
+ CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
}
else if (repl->op_type == OP_CONST)
curop = repl;
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
+ || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
- pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
pm->op_pmflags |= PMf_MAYBE_CONST;
- pm->op_pmpermflags |= PMf_MAYBE_CONST;
}
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_next = LINKLIST(repl);
repl->op_next = (OP*)rcop;
- pm->op_pmreplroot = scalar((OP*)rcop);
- pm->op_pmreplstart = LINKLIST(rcop);
+ pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
+ assert(!(pm->op_pmflags & PMf_ONCE));
+ pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
rcop->op_next = 0;
}
}
{
dVAR;
SVOP *svop;
+
+ PERL_ARGS_ASSERT_NEWSVOP;
+
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
{
dVAR;
PADOP *padop;
+
+ PERL_ARGS_ASSERT_NEWPADOP;
+
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
dVAR;
- assert(gv);
+
+ PERL_ARGS_ASSERT_NEWGVOP;
+
#ifdef USE_ITHREADS
GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
OP *pegop;
#endif
+ PERL_ARGS_ASSERT_PACKAGE;
+
save_hptr(&PL_curstash);
save_item(PL_curstname);
PL_curstash = gv_stashsv(sv, GV_ADD);
+
sv_setsv(PL_curstname, sv);
PL_hints |= HINT_BLOCK_SCOPE;
- PL_copline = NOLINE;
- PL_expect = XSTATE;
+ PL_parser->copline = NOLINE;
+ PL_parser->expect = XSTATE;
#ifndef PERL_MAD
op_free(o);
OP *pegop = newOP(OP_NULL,0);
#endif
+ PERL_ARGS_ASSERT_UTILIZE;
+
if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
*/
PL_hints |= HINT_BLOCK_SCOPE;
- PL_copline = NOLINE;
- PL_expect = XSTATE;
+ PL_parser->copline = NOLINE;
+ PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
#ifdef PERL_MAD
Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_LOAD_MODULE;
+
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
{
dVAR;
OP *veop, *imop;
-
OP * const modname = newSVOP(OP_CONST, 0, name);
+
+ PERL_ARGS_ASSERT_VLOAD_MODULE;
+
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
sv = va_arg(*args, SV*);
}
}
- {
- const line_t ocopline = PL_copline;
- COP * const ocurcop = PL_curcop;
- const int oexpect = PL_expect;
- utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
- veop, modname, imop);
- PL_expect = oexpect;
- PL_copline = ocopline;
- PL_curcop = ocurcop;
- }
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work. */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, FALSE);
+ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ veop, modname, imop);
+ LEAVE;
}
OP *
OP *doop;
GV *gv = NULL;
+ PERL_ARGS_ASSERT_DOFILE;
+
if (!force_builtin) {
gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
}
if (is_list_assignment(left)) {
+ static const char no_list_state[] = "Initialization of state variables"
+ " in list context currently forbidden";
OP *curop;
+ bool maybe_common_vars = TRUE;
PL_modcount = 0;
/* Grandfathering $[ assignment here. Bletch.*/
/* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
+ PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = mod(left, OP_AASSIGN);
if (PL_eval_start)
PL_eval_start = 0;
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
+ if ((left->op_type == OP_LIST
+ || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+ {
+ OP* lop = ((LISTOP*)left)->op_first;
+ maybe_common_vars = FALSE;
+ while (lop) {
+ if (lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY) {
+ if (!(lop->op_private & OPpLVAL_INTRO))
+ maybe_common_vars = TRUE;
+
+ if (lop->op_private & OPpPAD_STATE) {
+ if (left->op_private & OPpLVAL_INTRO) {
+ /* Each variable in state($a, $b, $c) = ... */
+ }
+ else {
+ /* Each state variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ yyerror(no_list_state);
+ } else {
+ /* Each my variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ } else if (lop->op_type == OP_UNDEF ||
+ lop->op_type == OP_PUSHMARK) {
+ /* undef may be interesting in
+ (state $a, undef, state $c) */
+ } else {
+ /* Other ops in the list. */
+ maybe_common_vars = TRUE;
+ }
+ lop = lop->op_sibling;
+ }
+ }
+ else if ((left->op_private & OPpLVAL_INTRO)
+ && ( left->op_type == OP_PADSV
+ || left->op_type == OP_PADAV
+ || left->op_type == OP_PADHV
+ || left->op_type == OP_PADANY))
+ {
+ maybe_common_vars = FALSE;
+ if (left->op_private & OPpPAD_STATE) {
+ /* All single variable list context state assignments, hence
+ state ($a) = ...
+ (state $a) = ...
+ state @a = ...
+ state (@a) = ...
+ (state @a) = ...
+ state %a = ...
+ state (%a) = ...
+ (state %a) = ...
+ */
+ yyerror(no_list_state);
+ }
+ }
+
/* PL_generation sorcery:
* an assignment like ($a,$b) = ($c,$d) is easier than
* ($a,$b) = ($c,$a), since there is no need for temporary vars.
* to store these values, evil chicanery is done with SvUVX().
*/
- {
+ if (maybe_common_vars) {
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
break;
}
else if (curop->op_type == OP_PUSHRE) {
- if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
- ((PMOP*)curop)->op_pmreplroot));
-#else
- GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
-#endif
+ if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
+ GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
break;
GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#else
+ GV *const gv
+ = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+ if (gv) {
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ break;
GvASSIGN_GENERATION_set(gv, PL_generation);
}
+#endif
}
else
break;
o->op_private |= OPpASSIGN_COMMON;
}
- if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
- && (left->op_type == OP_LIST
- || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
- {
- OP* lop = ((LISTOP*)left)->op_first;
- while (lop) {
- if (lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY)
- {
- if (lop->op_private & OPpPAD_STATE) {
- if (left->op_private & OPpLVAL_INTRO) {
- o->op_private |= OPpASSIGN_STATE;
- /* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(lop->op_targ));
- }
- else { /* we already checked for WARN_MISC before */
- Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
- PAD_COMPNAME_PV(lop->op_targ));
- }
- }
- }
- lop = lop->op_sibling;
- }
- }
-
- if (right && right->op_type == OP_SPLIT) {
+ if (right && right->op_type == OP_SPLIT && !PL_madskills) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
!(o->op_private & OPpASSIGN_COMMON) )
{
tmpop = ((UNOP*)left)->op_first;
- if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
+ if (tmpop->op_type == OP_GV
#ifdef USE_ITHREADS
- pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
+ && !pm->op_pmreplrootu.op_pmtargetoff
+#else
+ && !pm->op_pmreplrootu.op_pmtargetgv
+#endif
+ ) {
+#ifdef USE_ITHREADS
+ pm->op_pmreplrootu.op_pmtargetoff
+ = cPADOPx(tmpop)->op_padix;
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
+ pm->op_pmreplrootu.op_pmtargetgv
+ = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
pm->op_pmflags |= PMf_ONCE;
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
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);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
+ if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
+ o->op_private |= OPpCONST_ARYBASE;
+ }
}
}
return o;
CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
- if (label) {
- CopLABEL_set(cop, label);
- PL_hints |= HINT_BLOCK_SCOPE;
- }
cop->cop_seq = seq;
/* CopARYBASE is now "virtual", in that it's stored as a flag bit in
CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
cop->cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
+ if (label) {
+ cop->cop_hints_hash
+ = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
+
+ PL_hints |= HINT_BLOCK_SCOPE;
+ /* It seems that we need to defer freeing this pointer, as other parts
+ of the grammar end up wanting to copy it after this op has been
+ created. */
+ SAVEFREEPV(label);
+ }
- if (PL_copline == NOLINE)
+ if (PL_parser && PL_parser->copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
else {
- CopLINE_set(cop, PL_copline);
- PL_copline = NOLINE;
+ CopLINE_set(cop, PL_parser->copline);
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
}
#ifdef USE_ITHREADS
CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
#endif
CopSTASH_set(cop, PL_curstash);
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
+ /* this line can have a breakpoint - store the cop in IV */
AV *av = CopFILEAVx(PL_curcop);
if (av) {
SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
}
}
+ if (flags & OPf_SPECIAL)
+ op_null((OP*)cop);
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWLOGOP;
+
return new_logop(type, flags, &first, &other);
}
STATIC OP *
+S_search_const(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_SEARCH_CONST;
+
+ switch (o->op_type) {
+ case OP_CONST:
+ return o;
+ case OP_NULL:
+ if (o->op_flags & OPf_KIDS)
+ return search_const(cUNOPo->op_first);
+ break;
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ {
+ OP *kid;
+ if (!(o->op_flags & OPf_KIDS))
+ return NULL;
+ kid = cLISTOPo->op_first;
+ do {
+ switch (kid->op_type) {
+ case OP_ENTER:
+ case OP_NULL:
+ case OP_NEXTSTATE:
+ kid = kid->op_sibling;
+ break;
+ default:
+ if (kid != cLISTOPo->op_last)
+ return NULL;
+ goto last;
+ }
+ } while (kid);
+ if (!kid)
+ kid = cLISTOPo->op_last;
+last:
+ return search_const(kid);
+ }
+ }
+
+ return NULL;
+}
+
+STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
dVAR;
LOGOP *logop;
OP *o;
- OP *first = *firstp;
- OP * const other = *otherp;
+ OP *first;
+ OP *other;
+ OP *cstop = NULL;
+ int prepend_not = 0;
+
+ PERL_ARGS_ASSERT_NEW_LOGOP;
+
+ first = *firstp;
+ 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" */
+ /* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
- && (first->op_flags & OPf_SPECIAL)
- && (first->op_flags & OPf_KIDS)) {
+ && (first->op_flags & OPf_KIDS)
+ && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
+ && !PL_madskills) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
- else
- type = OP_AND;
- o = first;
- first = *firstp = cUNOPo->op_first;
- if (o->op_next)
- first->op_next = o->op_next;
- cUNOPo->op_first = NULL;
-#ifdef PERL_MAD
- op_getmad(o,first,'O');
-#else
- op_free(o);
-#endif
+ else
+ type = OP_AND;
+ op_null(first);
+ if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+ op_null(other);
+ prepend_not = 1; /* prepend a NOT op later */
+ }
}
}
- if (first->op_type == OP_CONST) {
- if (first->op_private & OPpCONST_STRICT)
- no_bareword_allowed(first);
- else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
+ /* search for a constant op that could let us fold the test */
+ if ((cstop = search_const(first))) {
+ if (cstop->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(cstop);
+ else if ((cstop->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))) {
+ if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
+ (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
+ (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
|| o2->op_type == OP_PADHV)
&& o2->op_private & OPpLVAL_INTRO
+ && !(o2->op_private & OPpPAD_STATE)
&& ckWARN(WARN_DEPRECATED))
{
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
}
if (warnop) {
const line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
PL_op_desc[warnop],
CHECKOP(type,logop);
- o = newUNOP(OP_NULL, 0, (OP*)logop);
+ o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
other->op_next = o;
return o;
LOGOP *logop;
OP *start;
OP *o;
+ OP *cstop;
+
+ PERL_ARGS_ASSERT_NEWCONDOP;
if (!falseop)
return newLOGOP(OP_AND, 0, first, trueop);
return newLOGOP(OP_OR, 0, first, falseop);
scalarboolean(first);
- if (first->op_type == OP_CONST) {
- if (first->op_private & OPpCONST_BARE &&
- first->op_private & OPpCONST_STRICT) {
- no_bareword_allowed(first);
- }
- if (SvTRUE(((SVOP*)first)->op_sv)) {
-#ifdef PERL_MAD
- if (PL_madskills) {
- trueop = newUNOP(OP_NULL, 0, trueop);
- op_getmad(first,trueop,'C');
- op_getmad(falseop,trueop,'e');
- }
- /* FIXME for MAD - should there be an ELSE here? */
-#else
- op_free(first);
- op_free(falseop);
-#endif
- return trueop;
- }
- else {
-#ifdef PERL_MAD
- if (PL_madskills) {
- falseop = newUNOP(OP_NULL, 0, falseop);
- op_getmad(first,falseop,'C');
- op_getmad(trueop,falseop,'t');
- }
- /* FIXME for MAD - should there be an ELSE here? */
-#else
+ if ((cstop = search_const(first))) {
+ /* Left or right arm of the conditional? */
+ const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
+ OP *live = left ? trueop : falseop;
+ OP *const dead = left ? falseop : trueop;
+ if (cstop->op_private & OPpCONST_BARE &&
+ cstop->op_private & OPpCONST_STRICT) {
+ no_bareword_allowed(cstop);
+ }
+ if (PL_madskills) {
+ /* This is all dead code when PERL_MAD is not defined. */
+ live = newUNOP(OP_NULL, 0, live);
+ op_getmad(first, live, 'C');
+ op_getmad(dead, live, left ? 'e' : 't');
+ } else {
op_free(first);
- op_free(trueop);
-#endif
- return falseop;
+ op_free(dead);
}
+ return live;
}
NewOp(1101, logop, 1, LOGOP);
logop->op_type = OP_COND_EXPR;
OP *leftstart;
OP *o;
+ PERL_ARGS_ASSERT_NEWRANGE;
+
NewOp(1101, range, 1, LOGOP);
range->op_type = OP_RANGE;
redo = LINKLIST(listop);
if (expr) {
- PL_copline = (line_t)whileline;
+ PL_parser->copline = (line_t)whileline;
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
I32 iterpflags = 0;
OP *madsv = NULL;
+ PERL_ARGS_ASSERT_NEWFOROP;
+
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)
+
+ /* The op_type check is needed to prevent a possible segfault
+ * if the loop variable is undeclared and 'strict vars' is in
+ * effect. This is illegal but is nonetheless parsed, so we
+ * may reach this point with an OP_CONST where we're expecting
+ * an OP_GV.
+ */
+ if (cUNOPx(sv)->op_first->op_type == OP_GV
+ && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
iterpflags |= OPpITER_DEF;
}
else if (sv->op_type == OP_PADSV) { /* private variable */
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
if (madsv)
op_getmad(madsv, (OP*)loop, 'v');
- PL_copline = forline;
+ PL_parser->copline = forline;
return newSTATEOP(0, label, wop);
}
dVAR;
OP *o;
+ PERL_ARGS_ASSERT_NEWLOOPEX;
+
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
- ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
+ ? SvPV_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
#ifdef PERL_MAD
op_other if the match fails.)
*/
-STATIC
-OP *
+STATIC OP *
S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
I32 enter_opcode, I32 leave_opcode,
PADOFFSET entertarg)
LOGOP *enterop;
OP *o;
+ PERL_ARGS_ASSERT_NEWGIVWHENOP;
+
NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = enter_opcode;
+ enterop->op_type = (Optype)enter_opcode;
enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_flags = (U8) OPf_KIDS;
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
[*] possibly surprising
*/
-STATIC
-bool
+STATIC bool
S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
+
switch(o->op_type) {
case OP_OR:
return looks_like_bool(cLOGOPo->op_first);
looks_like_bool(cLOGOPo->op_first)
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
+ case OP_NULL:
+ return (
+ o->op_flags & OPf_KIDS
+ && looks_like_bool(cUNOPo->op_first));
+
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
dVAR;
- assert( cond );
+ PERL_ARGS_ASSERT_NEWGIVENOP;
return newGIVWHENOP(
ref_array_or_hash(cond),
block,
const bool cond_llb = (!cond || looks_like_bool(cond));
OP *cond_op;
+ PERL_ARGS_ASSERT_NEWWHENOP;
+
if (cond_llb)
cond_op = cond;
else {
Perl_cv_undef(pTHX_ CV *cv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CV_UNDEF;
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(PL_comppad))
+ );
+
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvISXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
CvSTART(cv) = NULL;
LEAVE;
}
- SvPOK_off((SV*)cv); /* forget prototype */
+ SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV(cv) = NULL;
pad_undef(cv);
CvOUTSIDE(cv) = NULL;
}
if (CvCONST(cv)) {
- SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
CvCONST_off(cv);
}
if (CvISXSUB(cv) && CvXSUB(cv)) {
Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len)
{
+ PERL_ARGS_ASSERT_CV_CKPROTO_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. */
if (gv)
gv_efullname3(name = sv_newmortal(), gv, NULL);
- sv_setpv(msg, "Prototype mismatch:");
+ sv_setpvs(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
=cut
*/
SV *
-Perl_cv_const_sv(pTHX_ CV *cv)
+Perl_cv_const_sv(pTHX_ const CV *const cv)
{
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;
+ return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
dVAR;
SV *sv = NULL;
+ if (PL_madskills)
+ return NULL;
+
if (!o)
return NULL;
= (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;
+ const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
if (proto) {
assert(proto->op_type == OP_CONST);
- ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
}
else
ps = NULL;
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
+ if (!SvPOK((const SV *)gv)
+ && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
&& ckWARN_d(WARN_PROTOTYPE))
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
+ cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
}
if (ps)
- sv_setpvn((SV*)gv, ps, ps_len);
+ sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
else
- sv_setiv((SV*)gv, -1);
+ sv_setiv(MUTABLE_SV(gv), -1);
+
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
- PL_sub_generation++;
goto done;
}
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
{
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined", name);
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
- sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+ sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
GvCV(gv) = NULL;
cv = newCONSTSUB(NULL, name, const_sv);
}
- PL_sub_generation++;
+ mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+ (CvGV(cv) && GvSTASH(CvGV(cv)))
+ ? GvSTASH(CvGV(cv))
+ : CvSTASH(cv)
+ ? CvSTASH(cv)
+ : PL_curstash
+ );
if (PL_madskills)
goto install_block;
op_free(block);
|| block->op_type == OP_NULL
#endif
)) {
- rcv = (SV*)cv;
+ rcv = MUTABLE_SV(cv);
/* Might have had built-in attributes applied -- propagate them. */
CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
if (CvGV(cv) && GvSTASH(CvGV(cv)))
}
else {
/* possibly about to re-define existing subr -- ignore old cv */
- rcv = (SV*)PL_compcv;
+ rcv = MUTABLE_SV(PL_compcv);
if (name && GvSTASH(gv))
stash = GvSTASH(gv);
else
GvCV(gv) = cv;
if (PL_madskills) {
if (strEQ(name, "import")) {
- PL_formfeed = (SV*)cv;
+ PL_formfeed = MUTABLE_SV(cv);
Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
}
}
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
}
}
CvGV(cv) = gv;
CvSTASH(cv) = PL_curstash;
if (ps)
- sv_setpvn((SV*)cv, ps, ps_len);
+ sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if (PL_error_count) {
+ if (PL_parser && PL_parser->error_count) {
op_free(block);
block = NULL;
if (name) {
if (!block)
goto done;
+ /* If we assign an optree to a PVCV, then we've defined a subroutine that
+ the debugger could be able to set a breakpoint in, so signal to
+ pp_entereval that it should not throw away any saved lines at scope
+ exit. */
+
+ PL_breakable_sub_gen++;
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
}
if (name || aname) {
- const char *s;
- const char * const tname = (name ? name : aname);
-
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
CopFILE(PL_curcop),
(long)PL_subline, (long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
- hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
PUSHMARK(SP);
XPUSHs(tmpstr);
PUTBACK;
- call_sv((SV*)pcv, G_DISCARD);
+ call_sv(MUTABLE_SV(pcv), G_DISCARD);
}
}
}
- if ((s = strrchr(tname,':')))
- s++;
- else
- s = tname;
+ if (name && ! (PL_parser && PL_parser->error_count))
+ process_special_blocks(name, gv, cv);
+ }
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
- goto done;
+ done:
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ return cv;
+}
+
+STATIC void
+S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+ CV *const cv)
+{
+ const char *const colon = strrchr(fullname,':');
+ const char *const name = colon ? colon + 1 : fullname;
- if (strEQ(s, "BEGIN") && !PL_error_count) {
+ PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
+
+ if (*name == 'B') {
+ if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
DEBUG_x( dump_sub(gv) );
- Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
GvCV(gv) = 0; /* cv has been hijacked */
call_list(oldscope, PL_beginav);
CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
- else if (strEQ(s, "END") && !PL_error_count) {
- DEBUG_x( dump_sub(gv) );
- Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
- /* It's never too late to run a unitcheck block */
- DEBUG_x( dump_sub(gv) );
- Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK") && !PL_error_count) {
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT") && !PL_error_count) {
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
+ else
+ return;
+ } else {
+ if (*name == 'E') {
+ if strEQ(name, "END") {
+ DEBUG_x( dump_sub(gv) );
+ Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
+ } else
+ return;
+ } else if (*name == 'U') {
+ if (strEQ(name, "UNITCHECK")) {
+ /* It's never too late to run a unitcheck block */
+ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
+ }
+ else
+ return;
+ } else if (*name == 'C') {
+ if (strEQ(name, "CHECK")) {
+ if (PL_main_start && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run CHECK block");
+ Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
+ }
+ else
+ return;
+ } else if (*name == 'I') {
+ if (strEQ(name, "INIT")) {
+ if (PL_main_start && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run INIT block");
+ Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
+ }
+ else
+ return;
+ } else
+ return;
+ DEBUG_x( dump_sub(gv) );
+ GvCV(gv) = 0; /* cv has been hijacked */
}
-
- done:
- PL_copline = NOLINE;
- LEAVE_SCOPE(floor);
- return cv;
}
-/* XXX unsafe for threads if eval_owner isn't held */
/*
=for apidoc newCONSTSUB
dVAR;
CV* cv;
#ifdef USE_ITHREADS
- const char *const temp_p = CopFILE(PL_curcop);
- const STRLEN len = temp_p ? strlen(temp_p) : 0;
+ const char *const file = CopFILE(PL_curcop);
#else
SV *const temp_sv = CopFILESV(PL_curcop);
- STRLEN len;
- const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+ const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
#endif
- char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
+ if (IN_PERL_RUNTIME) {
+ /* at runtime, it's not safe to manipulate PL_curcop: it may be
+ * an op shared between threads. Use a non-shared COP for our
+ * dirty work */
+ SAVEVPTR(PL_curcop);
+ PL_curcop = &PL_compiling;
+ }
SAVECOPLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
+ CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
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. */
- cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
+ cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
+ XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- Safefree(file);
#ifdef USE_ITHREADS
if (stash)
{
CV *cv = newXS(name, subaddr, filename);
+ PERL_ARGS_ASSERT_NEWXS_FLAGS;
+
if (flags & XS_DYNAMIC_FILENAME) {
/* We need to "make arrangements" (ie cheat) to ensure that the
filename lasts as long as the PVCV we just created, but also doesn't
}
/* This gets free()d. :-) */
- sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
SV_HAS_TRAILING_NUL);
if (proto) {
/* This gives us the correct prototype, rather than one with the
}
CvFILE(cv) = proto_and_file + proto_len;
} else {
- sv_setpv((SV *)cv, proto);
+ sv_setpv(MUTABLE_SV(cv), proto);
}
return cv;
}
GV_ADDMULTI, SVt_PVCV);
register CV *cv;
+ PERL_ARGS_ASSERT_NEWXS;
+
if (!subaddr)
Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
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);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined"
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
- cv = (CV*)newSV(0);
- sv_upgrade((SV *)cv, SVt_PVCV);
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
if (name) {
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
CvGV(cv) = gv;
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
- if (name) {
- const char *s = strrchr(name,':');
- if (s)
- s++;
- else
- s = name;
-
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
- goto done;
-
- if (strEQ(s, "BEGIN")) {
- const I32 oldscope = PL_scopestack_ix;
- ENTER;
- SAVECOPFILE(&PL_compiling);
- SAVECOPLINE(&PL_compiling);
-
- Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- call_list(oldscope, PL_beginav);
-
- PL_curcop = &PL_compiling;
- CopHINTS_set(&PL_compiling, PL_hints);
- LEAVE;
- }
- else if (strEQ(s, "END")) {
- Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK")) {
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT")) {
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- }
+ if (name)
+ process_special_blocks(name, gv, cv);
else
CvANON_on(cv);
-done:
return cv;
}
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_copline != NOLINE)
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
: "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
#else
op_free(o);
#endif
- PL_copline = NOLINE;
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
#ifdef PERL_MAD
return pegop;
{
return newUNOP(OP_REFGEN, 0,
newSVOP(OP_ANONCODE, 0,
- (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
+ MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
}
OP *
Perl_oopsAV(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OOPSAV;
+
switch (o->op_type) {
case OP_PADSV:
o->op_type = OP_PADAV;
Perl_oopsHV(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OOPSHV;
+
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
Perl_newAVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWAVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
Perl_newHVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWHVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADHV;
o->op_ppaddr = PL_ppaddr[OP_PADHV];
Perl_newSVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWSVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADSV;
o->op_ppaddr = PL_ppaddr[OP_PADSV];
OP *
Perl_ck_anoncode(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_ANONCODE;
+
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
cSVOPo->op_sv = NULL;
Perl_ck_bitop(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_BITOP;
+
#define OP_IS_NUMCOMPARE(op) \
((op) == OP_LT || (op) == OP_I_LT || \
(op) == OP_GT || (op) == OP_I_GT || \
Perl_ck_concat(pTHX_ OP *o)
{
const OP * const kid = cUNOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_CONCAT;
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;
Perl_ck_spair(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_SPAIR;
+
if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
OP *
Perl_ck_delete(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_DELETE;
+
o = ck_fun(o);
o->op_private = 0;
if (o->op_flags & OPf_KIDS) {
OP *
Perl_ck_die(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_DIE;
+
#ifdef VMS
if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
{
dVAR;
+ PERL_ARGS_ASSERT_CK_EOF;
+
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
Perl_ck_eval(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_EVAL;
+
PL_hints |= HINT_BLOCK_SCOPE;
if (o->op_flags & OPf_KIDS) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
}
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)));
+ /* Store a copy of %^H that pp_entereval can pick up. */
+ OP *hhop = newSVOP(OP_HINTSEVAL, 0,
+ MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
OP *
Perl_ck_exit(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_EXIT;
+
#ifdef VMS
HV * const table = GvHV(PL_hintgv);
if (table) {
OP *
Perl_ck_exec(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_EXEC;
+
if (o->op_flags & OPf_STACKED) {
OP *kid;
o = ck_fun(o);
Perl_ck_exists(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_EXISTS;
+
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
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)
+ if (kid->op_type != OP_RV2CV
+ && !(PL_parser && PL_parser->error_count))
Perl_croak(aTHX_ "%s argument is not a subroutine name",
OP_DESC(o));
o->op_private |= OPpEXISTS_SUB;
else if (kid->op_type == OP_AELEM)
o->op_flags |= OPf_SPECIAL;
else if (kid->op_type != OP_HELEM)
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
+ Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
OP_DESC(o));
op_null(kid);
}
dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ PERL_ARGS_ASSERT_CK_RVCONST;
+
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (o->op_type == OP_RV2CV)
o->op_private &= ~1;
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_simple_NN(gv));
+ PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
dVAR;
const I32 type = o->op_type;
+ PERL_ARGS_ASSERT_CK_FTST;
+
if (o->op_flags & OPf_REF) {
NOOP;
}
#endif
return newop;
}
- if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
&& kidtype != OP_STAT && kidtype != OP_LSTAT)
const int type = o->op_type;
register I32 oa = PL_opargs[type] >> OASHIFT;
+ PERL_ARGS_ASSERT_CK_FUN;
+
if (o->op_flags & OPf_STACKED) {
if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
oa &= ~OA_OPTIONAL;
namesv = PAD_SVl(targ);
SvUPGRADE(namesv, SVt_PV);
if (*name != '$')
- sv_setpvn(namesv, "$", 1);
+ sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
}
}
dVAR;
GV *gv;
+ PERL_ARGS_ASSERT_CK_GLOB;
+
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
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);
- SvREFCNT_inc_void((SV*)GvCV(gv));
+ SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
GvIMPORTED_CV_on(gv);
LEAVE;
}
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
PADOFFSET offset;
+ PERL_ARGS_ASSERT_CK_GREP;
+
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
- /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
+ /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
OP* k;
else
scalar(kid);
o = ck_fun(o);
- if (PL_error_count)
+ if (PL_parser && PL_parser->error_count)
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
OP *
Perl_ck_index(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_INDEX;
+
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid)
}
OP *
-Perl_ck_lengthconst(pTHX_ OP *o)
-{
- /* XXX length optimization goes here */
- return ck_fun(o);
-}
-
-OP *
Perl_ck_lfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
+
+ PERL_ARGS_ASSERT_CK_LFUN;
+
return modkids(ck_fun(o), type);
}
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
+ PERL_ARGS_ASSERT_CK_DEFINED;
+
if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
}
OP *
+Perl_ck_readline(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_READLINE;
+
+ if (!(o->op_flags & OPf_KIDS)) {
+ OP * const newop
+ = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
+ op_free(o);
+#endif
+ return newop;
+ }
+ return o;
+}
+
+OP *
Perl_ck_rfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
+
+ PERL_ARGS_ASSERT_CK_RFUN;
+
return refkids(ck_fun(o), type);
}
{
register OP *kid;
+ PERL_ARGS_ASSERT_CK_LISTIOB;
+
kid = cLISTOPo->op_first;
if (!kid) {
o = force_list(o);
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
+ dVAR;
OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
/* 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))
+ && !(kid->op_private & OPpTARGET_MY)
+ /* Keep the full thing for madskills */
+ && !PL_madskills
+ )
{
OP * const kkid = kid->op_sibling;
/* 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;
}
if (kkid->op_type == OP_PADSV
&& (kkid->op_private & OPpLVAL_INTRO)
&& SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
- o->op_private |= OPpASSIGN_STATE;
+ const PADOFFSET target = kkid->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ kkid->op_flags
+ | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const condop = first->op_next;
/* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+ SvPADSTALE_on(PAD_SVl(target));
+
+ condop->op_type = OP_ONCE;
+ condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ condop->op_targ = target;
+ other->op_targ = target;
+
+ /* Because we change the type of the op here, we will skip the
+ assinment binop->op_last = binop->op_first->op_sibling; at the
+ end of Perl_newBINOP(). So need to do it here. */
+ cBINOPo->op_last = cBINOPo->op_first->op_sibling;
+
+ return nullop;
}
}
return o;
Perl_ck_match(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_MATCH;
+
if (o->op_type != OP_QR && PL_compcv) {
const PADOFFSET offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
Perl_ck_method(pTHX_ OP *o)
{
OP * const kid = cUNOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_METHOD;
+
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
const char * const method = SvPVX_const(sv);
OP *
Perl_ck_null(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_NULL;
PERL_UNUSED_CONTEXT;
return o;
}
{
dVAR;
HV * const table = GvHV(PL_hintgv);
+
+ PERL_ARGS_ASSERT_CK_OPEN;
+
if (table) {
SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
- const I32 mode = mode_from_discipline(*svp);
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
else if (mode & O_TEXT)
svp = hv_fetchs(table, "open_OUT", FALSE);
if (svp && *svp) {
- const I32 mode = mode_from_discipline(*svp);
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
else if (mode & O_TEXT)
o->op_private |= OPpOPEN_OUT_CRLF;
}
}
- if (o->op_type == OP_BACKTICK)
+ if (o->op_type == OP_BACKTICK) {
+ if (!(o->op_flags & OPf_KIDS)) {
+ OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
+ op_free(o);
+#endif
+ return newop;
+ }
return o;
+ }
{
/* In case of three-arg dup open remove strictness
* from the last arg if it is a bareword. */
OP *
Perl_ck_repeat(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_REPEAT;
+
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
o->op_private |= OPpREPEAT_DOLIST;
cBINOPo->op_first = force_list(cBINOPo->op_first);
dVAR;
GV* gv = NULL;
+ PERL_ARGS_ASSERT_CK_REQUIRE;
+
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
SV * const sv = kid->op_sv;
U32 was_readonly = SvREADONLY(sv);
char *s;
+ STRLEN len;
+ const char *end;
if (was_readonly) {
if (SvFAKE(sv)) {
}
}
- for (s = SvPVX(sv); *s; s++) {
+ s = SvPVX(sv);
+ len = SvCUR(sv);
+ end = s + len;
+ for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
- const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, len, char);
- SvCUR_set(sv, SvCUR(sv) - 1);
+ Move(s+2, s+1, end - s - 1, char);
+ --end;
}
}
+ SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
SvFLAGS(sv) |= was_readonly;
}
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
+
+ PERL_ARGS_ASSERT_CK_RETURN;
+
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling)
+ if ((kid->op_type == OP_NULL)
+ && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
+ /* This is a do block */
+ OP *op = kUNOP->op_first;
+ if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
+ op = cUNOPx(op)->op_first;
+ assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+ /* Force the use of the caller's context */
+ op->op_flags |= OPf_SPECIAL;
+ }
+ }
}
+
return o;
}
{
dVAR;
OP* kid;
+
+ PERL_ARGS_ASSERT_CK_SELECT;
+
if (o->op_flags & OPf_KIDS) {
kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_sibling) {
dVAR;
const I32 type = o->op_type;
+ PERL_ARGS_ASSERT_CK_SHIFT;
+
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
/* FIXME - this can be refactored to reduce code in #ifdefs */
dVAR;
OP *firstkid;
+ PERL_ARGS_ASSERT_CK_SORT;
+
if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
HV * const hinthv = GvHV(PL_hintgv);
if (hinthv) {
int descending;
GV *gv;
const char *gvname;
+
+ PERL_ARGS_ASSERT_SIMPLIFY_SORT;
+
if (!(o->op_flags & OPf_STACKED))
return;
GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
dVAR;
register OP *kid;
+ PERL_ARGS_ASSERT_CK_SPLIT;
+
if (o->op_flags & OPf_STACKED)
return no_fh_allowed(o);
Perl_ck_join(pTHX_ OP *o)
{
const OP * const kid = cLISTOPo->op_first->op_sibling;
+
+ PERL_ARGS_ASSERT_CK_JOIN;
+
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? re->precomp : "STRING";
+ const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
+ const STRLEN len = re ? RX_PRELEN(re) : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%s/ should probably be written as \"%s\"",
- pmstr, pmstr);
+ "/%.*s/ should probably be written as \"%.*s\"",
+ (int)len, pmstr, (int)len, pmstr);
}
}
return ck_fun(o);
const char *e = NULL;
bool delete_op = 0;
+ PERL_ARGS_ASSERT_CK_SUBR;
+
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
if (SvPOK(cv)) {
STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, len);
+ proto = SvPV(MUTABLE_SV(cv), len);
proto_end = proto + len;
}
- if (CvASSERTION(cv)) {
- U32 asserthints = 0;
- HV *const hinthv = GvHV(PL_hintgv);
- if (hinthv) {
- SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
- if (svp && *svp)
- asserthints = SvUV(*svp);
- }
- if (asserthints & HINT_ASSERTING) {
- if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
- o->op_private |= OPpENTERSUB_DB;
- }
- else {
- delete_op = 1;
- if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
- Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
- "Impossible to activate assertion call");
- }
- }
- }
}
}
}
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
OP* o3;
+ if (PL_madskills && o2->op_type == OP_STUB) {
+ o2 = o2->op_sibling;
+ continue;
+ }
if (PL_madskills && o2->op_type == OP_NULL)
o3 = ((UNOP*)o2)->op_first;
else
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[');
+ while (*--p != '[') {}
bad_type(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
gv_ename(namegv), o3);
OP *
Perl_ck_svconst(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
SvREADONLY_on(cSVOPo->op_sv);
return o;
OP *
Perl_ck_trunc(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_TRUNC;
+
if (o->op_flags & OPf_KIDS) {
SVOP *kid = (SVOP*)cUNOPo->op_first;
Perl_ck_unpack(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_UNPACK;
+
if (kid->op_sibling) {
kid = kid->op_sibling;
if (!kid->op_sibling)
OP *
Perl_ck_substr(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_SUBSTR;
+
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
return o;
}
+OP *
+Perl_ck_each(pTHX_ OP *o)
+{
+ dVAR;
+ OP *kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_EACH;
+
+ if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+ const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+ : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+ o->op_type = new_type;
+ o->op_ppaddr = PL_ppaddr[new_type];
+ }
+ else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+ || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+ )) {
+ bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+ return o;
+ }
+ return ck_fun(o);
+}
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
for (; o; o = o->op_next) {
if (o->op_opt)
break;
+ /* By default, this op has now been optimised. A couple of cases below
+ clear this again. */
+ o->op_opt = 1;
PL_op = o;
switch (o->op_type) {
- case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
- o->op_opt = 1;
break;
case OP_CONST:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
#ifdef USE_ITHREADS
+ case OP_HINTSEVAL:
case OP_METHOD_NAMED:
/* Relocate sv to the pad for thread safety.
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
+ if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
- else if (o->op_type == OP_CONST
+ else if (o->op_type != OP_METHOD_NAMED
&& 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
o->op_targ = ix;
}
#endif
- o->op_opt = 1;
break;
case OP_CONCAT:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
if (o->op_flags & OPf_STACKED) /* chained concats */
- goto ignore_optimization;
+ break; /* ignore_optimization */
else {
/* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
o->op_targ = o->op_next->op_targ;
}
op_null(o->op_next);
}
- ignore_optimization:
- o->op_opt = 1;
break;
case OP_STUB:
if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- o->op_opt = 1;
break; /* Scalar stub must produce undef. List stub is noop */
}
goto nothin;
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE
- || o->op_targ == OP_SETSTATE)
+ || o->op_targ == OP_DBSTATE)
{
PL_curcop = ((COP*)o);
}
has already occurred. This doesn't fix the real problem,
though (See 20010220.007). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
- if (oldop && o->op_next) {
- oldop->op_next = o->op_next;
- continue;
- }
- break;
+ o->op_opt = 0;
+ /* FALL THROUGH */
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
- nothin:
+ nothin:
if (oldop && o->op_next) {
oldop->op_next = o->op_next;
+ o->op_opt = 0;
continue;
}
- o->op_opt = 1;
break;
case OP_PADAV:
o->op_flags |= OPf_SPECIAL;
o->op_type = OP_AELEMFAST;
}
- o->op_opt = 1;
break;
}
op_null(o->op_next);
}
- o->op_opt = 1;
break;
case OP_MAPWHILE:
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
- o->op_opt = 1;
+ case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
case OP_ENTERLOOP:
case OP_ENTERITER:
- o->op_opt = 1;
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
peep(cLOOP->op_lastop);
break;
- case OP_QR:
- case OP_MATCH:
case OP_SUBST:
- o->op_opt = 1;
- while (cPMOP->op_pmreplstart &&
- cPMOP->op_pmreplstart->op_type == OP_NULL)
- cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
- peep(cPMOP->op_pmreplstart);
+ assert(!(cPMOP->op_pmflags & PMf_ONCE));
+ while (cPMOP->op_pmstashstartu.op_pmreplstart &&
+ cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
+ cPMOP->op_pmstashstartu.op_pmreplstart
+ = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
+ peep(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
case OP_EXEC:
- o->op_opt = 1;
if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
&& ckWARN(WARN_SYNTAX))
{
const char *key = NULL;
STRLEN keylen;
- o->op_opt = 1;
-
if (((BINOP*)o)->op_last->op_type != OP_CONST)
break;
/* make @a = sort @a act in-place */
- o->op_opt = 1;
-
oright = cUNOPx(oright)->op_sibling;
if (!oright)
break;
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
LISTOP *enter, *exlist;
- o->op_opt = 1;
enter = (LISTOP *) o->op_next;
if (!enter)
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)
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
}
- default:
- o->op_opt = 1;
+ case OP_QR:
+ case OP_MATCH:
+ if (!(cPMOP->op_pmflags & PMf_ONCE)) {
+ assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
+ }
break;
}
oldop = o;
LEAVE;
}
-char*
+const char*
Perl_custom_op_name(pTHX_ const OP* o)
{
dVAR;
SV* keysv;
HE* he;
+ PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+
if (!PL_custom_op_names) /* This probably shouldn't happen */
return (char *)PL_op_name[OP_CUSTOM];
return SvPV_nolen(HeVAL(he));
}
-char*
+const char*
Perl_custom_op_desc(pTHX_ const OP* o)
{
dVAR;
SV* keysv;
HE* he;
+ PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
+
if (!PL_custom_op_descs)
return (char *)PL_op_desc[OP_CUSTOM];
#endif
}
EXTEND(sp, 1);
- ST(0) = (SV*)XSANY.any_ptr;
+ ST(0) = MUTABLE_SV(XSANY.any_ptr);
XSRETURN(1);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff