/* op.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 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
backward in the execution order. (The bottom-up parser builds that
part of the execution order it knows about, but if you follow the "next"
links around, you'll find it's actually a closed loop through the
-top level node.
+top level node.)
Whenever the bottom-up parser gets to a node that supplies context to
its components, it invokes that portion of the top-down pass that applies
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.
*/
#include "keywords.h"
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
#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_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
- (void*)cSVOPo_sv));
+ SVfARG(cSVOPo_sv)));
}
/* "register" allocation */
{
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 != '$') {
- 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"));
- }
-
/* 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;
}
}
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
if (o->op_flags & OPf_KIDS) {
register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
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
/* FALL THROUGH */
case OP_TRANS:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+#ifdef USE_ITHREADS
+ if (cPADOPo->op_padix > 0) {
+ pad_swipe(cPADOPo->op_padix, TRUE);
+ cPADOPo->op_padix = 0;
+ }
+#else
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
+#endif
}
else {
- Safefree(cPVOPo->op_pv);
+ PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
}
break;
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) {
}
break;
- case OP_THREADSV:
- o->op_flags |= OPf_MOD; /* XXX ??? */
- break;
-
case OP_RV2AV:
case OP_RV2HV:
if (set_op_ref)
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 = get_cv("DB::postponed", FALSE);
+ 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((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);
}
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 complement = o->op_private & OPpTRANS_COMPLEMENT;
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))
else
bits = 8;
- Safefree(cPVOPo->op_pv);
+ PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
- cSVOPo->op_sv = (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));
+ PAD_SETSV(cPADOPo->op_padix, swash);
+ SvPADTMP_on(swash);
+ SvREADONLY_on(swash);
+#else
+ cSVOPo->op_sv = swash;
+#endif
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
if (!del && havefinal && rlen)
- (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
+ (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
if (grows)
}
else if (j >= (I32)rlen)
j = rlen - 1;
- else
- cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
+ else {
+ tbl =
+ (short *)
+ PerlMemShared_realloc(tbl,
+ (0x101+rlen-j) * sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
+ }
tbl[0x100] = (short)(rlen - j);
for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
}
}
}
+
+ if(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) && (*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);
+ 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 (strEQ("\\s+", PM_GETRE(pm)->precomp))
- 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];
return CHECKOP(type, svop);
}
+#ifdef USE_ITHREADS
OP *
Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
{
dVAR;
PADOP *padop;
+
+ PERL_ARGS_ASSERT_NEWPADOP;
+
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix = pad_alloc(type, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
- if (sv)
- SvPADTMP_on(sv);
+ assert(sv);
+ SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
padop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
padop->op_targ = pad_alloc(type, SVs_PADTMP);
return CHECKOP(type, padop);
}
+#endif
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWGVOP;
+
#ifdef USE_ITHREADS
- if (gv)
- GvIN_PAD_on(gv);
- return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
+ GvIN_PAD_on(gv);
+ return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#else
- return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
+ return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#endif
}
Perl_package(pTHX_ OP *o)
{
dVAR;
- const char *name;
- STRLEN len;
+ SV *const sv = cSVOPo->op_sv;
#ifdef PERL_MAD
OP *pegop;
#endif
+ PERL_ARGS_ASSERT_PACKAGE;
+
save_hptr(&PL_curstash);
save_item(PL_curstname);
- name = SvPV_const(cSVOPo->op_sv, len);
- PL_curstash = gv_stashpvn(name, len, TRUE);
- sv_setpvn(PL_curstname, name, len);
+ PL_curstash = gv_stashsv(sv, GV_ADD);
+
+ sv_setsv(PL_curstname, sv);
PL_hints |= HINT_BLOCK_SCOPE;
- PL_copline = NOLINE;
- 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");
SV *meth;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
- Perl_croak(aTHX_ "Version number must be constant number");
+ Perl_croak(aTHX_ "Version number must be a constant number");
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
*/
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
(or 0 for no flags). ver, if specified, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
-method, similar to C<use Foo::Bar VERSION LIST>.
+method, similar to C<use Foo::Bar VERSION LIST>. They must be
+terminated with a final NULL pointer. Note that this list can only
+be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
+Otherwise at least a single NULL pointer to designate the default
+import list is required.
=cut */
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);
- GvASSIGN_GENERATION_set(gv, PL_generation);
}
- }
- else
- break;
+#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;
}
lastop = curop;
}
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_pmreplrootu.op_pmtargetoff
+#else
+ && !pm->op_pmreplrootu.op_pmtargetgv
+#endif
+ ) {
#ifdef USE_ITHREADS
- pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
+ 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;
((LISTOP*)right)->op_last->op_type == OP_CONST)
{
SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
- if (SvIVX(sv) == 0)
+ if (SvIOK(sv) && SvIVX(sv) == 0)
sv_setiv(sv, PL_modcount+1);
}
}
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 */
+ deprecate("assignment to $[");
+ 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
+ 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;
return newop;
}
op_free(first);
+ if (other->op_type == OP_LEAVE)
+ other = newUNOP(OP_NULL, OPf_SPECIAL, other);
return other;
}
else {
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);
}
+ if (live->op_type == OP_LEAVE)
+ live = newUNOP(OP_NULL, OPf_SPECIAL, live);
+ 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 */
}
sv = NULL;
}
- else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
- padoff = sv->op_targ;
- if (PL_madskills)
- madsv = sv;
- else {
- sv->op_targ = 0;
- iterflags |= OPf_SPECIAL;
- op_free(sv);
- }
- sv = NULL;
- }
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
if (padoff) {
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, savepv(label->op_type == OP_CONST
- ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
+ o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
+ ? 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:
+ case OP_DOR:
return looks_like_bool(cLOGOPo->op_first);
case OP_AND:
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:
- /* 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_DEFINED: case OP_EXISTS:
case OP_MATCH: case OP_EOF:
+ case OP_FLOP:
+
return TRUE;
case OP_CONST:
|| cSVOPo->op_sv == &PL_sv_no)
return TRUE;
-
+ else
+ return FALSE;
+
/* FALL THROUGH */
default:
return FALSE;
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, (void*)name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
}
}
=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;
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
dVAR;
- const char *aname;
GV *gv;
const char *ps;
STRLEN ps_len;
= (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;
+ bool has_name;
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 (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
+ if (name) {
+ gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ has_name = TRUE;
+ } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
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_const(sv);
+ gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
+ has_name = TRUE;
+ } else if (PL_curstash) {
+ gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
+ has_name = FALSE;
+ } else {
+ gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
+ has_name = FALSE;
}
- else
- aname = NULL;
-
- gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
- : gv_fetchpv(aname ? aname
- : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- gv_fetch_flags, SVt_PVCV);
if (!PL_madskills) {
if (o)
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;
}
cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
-#ifdef GV_UNIQUE_CHECK
- if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
- Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
- }
-#endif
-
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
#ifdef PERL_MAD
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
-#ifdef GV_UNIQUE_CHECK
- if (exists && GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
- }
-#endif
-
/* if the subroutine doesn't exist and wasn't pre-declared
* with a prototype, assume it will be AUTOLOADed,
* skipping the prototype check
&& (!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);
PL_compcv = NULL;
goto done;
}
- if (attrs) {
- HV *stash;
- SV *rcv;
-
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
- * before we clobber PL_compcv.
- */
- if (cv && (!block
+ if (cv) { /* must reuse cv if autoloaded */
+ /* transfer PL_compcv to cv */
+ if (block
#ifdef PERL_MAD
- || block->op_type == OP_NULL
+ && 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);
- if (CvGV(cv) && GvSTASH(CvGV(cv)))
- stash = GvSTASH(CvGV(cv));
- else if (CvSTASH(cv))
- stash = CvSTASH(cv);
- else
- stash = PL_curstash;
+ ) {
+ cv_undef(cv);
+ CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
+ CvOUTSIDE(PL_compcv) = 0;
+ CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST(PL_compcv) = 0;
+ /* inner references to PL_compcv must be fixed up ... */
+ pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
}
else {
- /* possibly about to re-define existing subr -- ignore old cv */
- rcv = (SV*)PL_compcv;
- if (name && GvSTASH(gv))
- stash = GvSTASH(gv);
- else
- stash = PL_curstash;
- }
- apply_attrs(stash, rcv, attrs, FALSE);
- }
- if (cv) { /* must reuse cv if autoloaded */
- 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;
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
}
- /* transfer PL_compcv to cv */
- cv_undef(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv);
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
- CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvOUTSIDE(PL_compcv) = 0;
- CvPADLIST(cv) = CvPADLIST(PL_compcv);
- CvPADLIST(PL_compcv) = 0;
- /* inner references to PL_compcv must be fixed up ... */
- pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
/* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
PL_compcv = cv;
- if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
}
else {
cv = PL_compcv;
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;
- CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH(cv) = PL_curstash;
+ if (!CvGV(cv)) {
+ CvGV(cv) = gv;
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH(cv) = PL_curstash;
+ }
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
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) {
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
+ Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
}
}
}
if (!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));
CvCONST_on(cv);
}
- if (name || aname) {
- const char *s;
- const char * const tname = (name ? name : aname);
-
+ if (has_name) {
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);
+ }
+
+ 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 (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
- goto done;
+ PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
- if (strEQ(s, "BEGIN") && !PL_error_count) {
+ if (*name == 'B') {
+ if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
- if (!PL_beginav)
- PL_beginav = newAV();
DEBUG_x( dump_sub(gv) );
- av_push(PL_beginav, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav, 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) {
- if (!PL_endav)
- PL_endav = newAV();
- DEBUG_x( dump_sub(gv) );
- av_unshift(PL_endav, 1);
- av_store(PL_endav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
- /* It's never too late to run a unitcheck block */
- if (!PL_unitcheckav)
- PL_unitcheckav = newAV();
- DEBUG_x( dump_sub(gv) );
- av_unshift(PL_unitcheckav, 1);
- av_store(PL_unitcheckav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK") && !PL_error_count) {
- if (!PL_checkav)
- PL_checkav = newAV();
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- av_unshift(PL_checkav, 1);
- av_store(PL_checkav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT") && !PL_error_count) {
- if (!PL_initav)
- PL_initav = newAV();
- DEBUG_x( dump_sub(gv) );
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- av_push(PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
+ else
+ return;
+ } else {
+ if (*name == 'E') {
+ if strEQ(name, "END") {
+ DEBUG_x( dump_sub(gv) );
+ Perl_av_create_and_unshift_one(aTHX_ &PL_endav, 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
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
+which won't be called if used as a destructor, but will suppress the overhead
+of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
+compile time.)
+
=cut
*/
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")) {
- if (!PL_beginav)
- PL_beginav = newAV();
- av_push(PL_beginav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "END")) {
- if (!PL_endav)
- PL_endav = newAV();
- av_unshift(PL_endav, 1);
- av_store(PL_endav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "CHECK")) {
- if (!PL_checkav)
- PL_checkav = newAV();
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
- av_unshift(PL_checkav, 1);
- av_store(PL_checkav, 0, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- else if (strEQ(s, "INIT")) {
- if (!PL_initav)
- PL_initav = newAV();
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
- av_push(PL_initav, (SV*)cv);
- GvCV(gv) = 0; /* cv has been hijacked */
- }
- }
+ if (name)
+ process_special_blocks(name, gv, cv);
else
CvANON_on(cv);
-done:
return cv;
}
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
- }
-#endif
GvMULTI_on(gv);
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);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ if (o) {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
+ } else {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format STDOUT redefined");
+ }
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
#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];
return o;
}
- else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
- o->op_flags |= OPpDONE_SVREF;
- return o;
- }
return newUNOP(OP_RV2SV, 0, scalar(o));
}
OP *
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) {
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
OP_DESC(o));
}
+ if (kid->op_private & OPpLVAL_INTRO)
+ o->op_private |= OPpLVAL_INTRO;
op_null(kid);
}
return o;
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;
/* establish postfix order */
enter->op_next = (OP*)enter;
+ CHECKOP(OP_ENTERTRY, enter);
+
o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
o->op_type = OP_LEAVETRY;
o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
}
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;
if (badthing)
Perl_croak(aTHX_
"Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
- (void*)kidsv, badthing);
+ SVfARG(kidsv), badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
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;
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
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 */
-#ifdef PERL_MAD
- OP * const oldo = o;
-#else
- op_free(o);
-#endif
- argop = newUNOP(OP_RV2AV, 0,
+ OP *argop = newUNOP(OP_RV2AV, 0,
scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
#ifdef PERL_MAD
+ OP * const oldo = o;
o = newUNOP(type, 0, scalar(argop));
op_getmad(oldo,o,'O');
return o;
#else
+ op_free(o);
return newUNOP(type, 0, scalar(argop));
#endif
}
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);
if (o3->op_type == OP_RV2SV ||
o3->op_type == OP_PADSV ||
o3->op_type == OP_HELEM ||
- o3->op_type == OP_AELEM ||
- o3->op_type == OP_THREADSV)
+ o3->op_type == OP_AELEM)
goto wrapref;
if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o3);
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), (void*)cv);
+ gv_ename(namegv), SVfARG(cv));
}
}
else
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;
}
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
- (void*)sv);
+ SVfARG(sv));
}
}
else if (o->op_next->op_type == OP_READLINE
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 the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
+ if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
/* 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];
{
dVAR;
dXSARGS;
+ SV *const sv = MUTABLE_SV(XSANY.any_ptr);
if (items != 0) {
NOOP;
#if 0
+ /* diag_listed_as: SKIPME */
Perl_croak(aTHX_ "usage: %s::%s()",
HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
#endif
}
+ if (!sv) {
+ XSRETURN(0);
+ }
EXTEND(sp, 1);
- ST(0) = (SV*)XSANY.any_ptr;
+ ST(0) = sv;
XSRETURN(1);
}