#include "perl.h"
#include "keywords.h"
#include "feature.h"
+#include "regcomp.h"
#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
-#if defined(PL_OP_SLAB_ALLOC)
+/* See the explanatory comments above struct opslab in op.h. */
#ifdef PERL_DEBUG_READONLY_OPS
-# define PERL_SLAB_SIZE 4096
+# define PERL_SLAB_SIZE 128
+# define PERL_MAX_SLAB_SIZE 4096
# include <sys/mman.h>
#endif
#ifndef PERL_SLAB_SIZE
-#define PERL_SLAB_SIZE 2048
+# define PERL_SLAB_SIZE 64
+#endif
+#ifndef PERL_MAX_SLAB_SIZE
+# define PERL_MAX_SLAB_SIZE 2048
#endif
-void *
-Perl_Slab_Alloc(pTHX_ size_t sz)
+/* rounds up to nearest pointer */
+#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+
+static OPSLAB *
+S_new_slab(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 **
- * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
- * Add an overhead for pointer to slab and round up as a number of pointers
- */
- sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
- if ((PL_OpSpace -= sz) < 0) {
#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();
- }
+ OPSLAB *slab = (OPSLAB *) mmap(0, sz * 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) sz, slab));
+ if (slab == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ slab->opslab_size = (U16)sz;
#else
-
- PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
+ OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
- if (!PL_OpPtr) {
- return NULL;
- }
- /* 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.
- * Latter is to mimic the '-=' in the if() above
- */
- PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
- /* Allocation pointer starts at the top.
- Theory: because we build leaves before trunk allocating at end
- means that at run time access is cache friendly upward
- */
- PL_OpPtr += PERL_SLAB_SIZE;
+ slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ return slab;
+}
+
+/* requires double parens and aTHX_ */
+#define DEBUG_S_warn(args) \
+ DEBUG_S( \
+ PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
+ )
+
+void *
+Perl_Slab_Alloc(pTHX_ size_t sz)
+{
+ dVAR;
+ OPSLAB *slab;
+ OPSLAB *slab2;
+ OPSLOT *slot;
+ OP *o;
+ size_t opsz, space;
+
+ if (!PL_compcv || CvROOT(PL_compcv)
+ || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
+ return PerlMemShared_calloc(1, sz);
+
+ if (!CvSTART(PL_compcv)) { /* sneak it in here */
+ CvSTART(PL_compcv) =
+ (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
+ CvSLABBED_on(PL_compcv);
+ slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
+ }
+ else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
+
+ opsz = SIZE_TO_PSIZE(sz);
+ sz = opsz + OPSLOT_HEADER_P;
+
+ if (slab->opslab_freed) {
+ OP **too = &slab->opslab_freed;
+ o = *too;
+ DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
+ while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+ DEBUG_S_warn((aTHX_ "Alas! too small"));
+ o = *(too = &o->op_next);
+ if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
+ }
+ if (o) {
+ *too = o->op_next;
+ Zero(o, opsz, I32 *);
+ o->op_slabbed = 1;
+ return (void *)o;
+ }
+ }
+
+#define INIT_OPSLOT \
+ slot->opslot_slab = slab; \
+ slot->opslot_next = slab2->opslab_first; \
+ slab2->opslab_first = slot; \
+ o = &slot->opslot_op; \
+ o->op_slabbed = 1
+
+ /* The partially-filled slab is next in the chain. */
+ slab2 = slab->opslab_next ? slab->opslab_next : slab;
+ if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
+ /* Remaining space is too small. */
+
+ /* If we can fit a BASEOP, add it to the free chain, so as not
+ to waste it. */
+ if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+ slot = &slab2->opslab_slots;
+ INIT_OPSLOT;
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+ slab->opslab_freed = o;
+ }
+
+ /* Create a new slab. Make this one twice as big. */
+ slot = slab2->opslab_first;
+ while (slot->opslot_next) slot = slot->opslot_next;
+ slab2 = S_new_slab(aTHX_
+ (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
+ ? PERL_MAX_SLAB_SIZE
+ : (DIFF(slab2, slot)+1)*2);
+ slab2->opslab_next = slab->opslab_next;
+ slab->opslab_next = slab2;
+ }
+ assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
+
+ /* Create a new op slot */
+ slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
+ assert(slot >= &slab2->opslab_slots);
+ if (DIFF(&slab2->opslab_slots, slot)
+ < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
+ slot = &slab2->opslab_slots;
+ INIT_OPSLOT;
+ DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
+ return (void *)o;
+}
+
+#undef INIT_OPSLOT
#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
+void
+Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
+{
+ PERL_ARGS_ASSERT_SLAB_TO_RO;
+
+ if (slab->opslab_readonly) return;
+ slab->opslab_readonly = 1;
+ for (; slab; slab = slab->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
+ (unsigned long) slab->opslab_size, slab));*/
+ if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+ (unsigned long)slab->opslab_size, errno);
}
- assert( PL_OpSpace >= 0 );
- /* Move the allocation pointer down */
- PL_OpPtr -= sz;
- assert( PL_OpPtr > (I32 **) PL_OpSlab );
- *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
- (*PL_OpSlab)++; /* Increment use count of slab */
- assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
- assert( *PL_OpSlab > 0 );
- 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;
+Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
+{
+ OPSLAB *slab2;
+
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
+
+ if (!slab->opslab_readonly) return;
+ slab2 = slab;
+ for (; slab2; slab2 = slab2->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
+ (unsigned long) size, slab2));*/
+ if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+ PROT_READ|PROT_WRITE)) {
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+ (unsigned long)slab2->opslab_size, errno);
+ }
+ }
+ slab->opslab_readonly = 0;
+}
+
+#else
+# define Slab_to_rw(op)
+#endif
- /* 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 */
+/* This cannot possibly be right, but it was copied from the old slab
+ allocator, to which it was originally added, without explanation, in
+ commit 083fcd5. */
+#ifdef NETWARE
+# define PerlMemShared PerlMem
+#endif
- PL_slabs = NULL;
- PL_slab_count = 0;
+void
+Perl_Slab_Free(pTHX_ void *op)
+{
+ dVAR;
+ OP * const o = (OP *)op;
+ OPSLAB *slab;
- /* Force a new slab for any further allocation. */
- PL_OpSpace = 0;
+ PERL_ARGS_ASSERT_SLAB_FREE;
- 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);
- }
+ if (!o->op_slabbed) {
+ if (!o->op_static)
+ PerlMemShared_free(op);
+ return;
}
- free(slabs);
+ slab = OpSLAB(o);
+ /* If this op is already freed, our refcount will get screwy. */
+ assert(o->op_type != OP_FREED);
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+ slab->opslab_freed = o;
+ DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
+ OpslabREFCNT_dec_padok(slab);
}
-STATIC void
-S_Slab_to_rw(pTHX_ void *op)
+void
+Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
{
- I32 * const * const ptr = (I32 **) op;
- I32 * const slab = ptr[-1];
+ dVAR;
+ const bool havepad = !!PL_comppad;
+ PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
+ if (havepad) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+ }
+ opslab_free(slab);
+ if (havepad) LEAVE;
+}
- PERL_ARGS_ASSERT_SLAB_TO_RW;
+void
+Perl_opslab_free(pTHX_ OPSLAB *slab)
+{
+ dVAR;
+ OPSLAB *slab2;
+ PERL_ARGS_ASSERT_OPSLAB_FREE;
+ DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
+ assert(slab->opslab_refcnt == 1);
+ for (; slab; slab = slab2) {
+ slab2 = slab->opslab_next;
+#ifdef DEBUGGING
+ slab->opslab_refcnt = ~(size_t)0;
+#endif
+#ifdef PERL_DEBUG_READONLY_OPS
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
+ slab));
+ if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+ perror("munmap failed");
+ abort();
+ }
+#else
+ PerlMemShared_free(slab);
+#endif
+ }
+}
- 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);
+void
+Perl_opslab_force_free(pTHX_ OPSLAB *slab)
+{
+ OPSLAB *slab2;
+ OPSLOT *slot;
+#ifdef DEBUGGING
+ size_t savestack_count = 0;
+#endif
+ PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
+ slab2 = slab;
+ do {
+ for (slot = slab2->opslab_first;
+ slot->opslot_next;
+ slot = slot->opslot_next) {
+ if (slot->opslot_op.op_type != OP_FREED
+ && !(slot->opslot_op.op_savefree
+#ifdef DEBUGGING
+ && ++savestack_count
+#endif
+ )
+ ) {
+ assert(slot->opslot_op.op_slabbed);
+ slab->opslab_refcnt++; /* op_free may free slab */
+ op_free(&slot->opslot_op);
+ if (!--slab->opslab_refcnt) goto free;
+ }
+ }
+ } while ((slab2 = slab2->opslab_next));
+ /* > 1 because the CV still holds a reference count. */
+ if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
+#ifdef DEBUGGING
+ assert(savestack_count == slab->opslab_refcnt-1);
+#endif
+ return;
}
+ free:
+ opslab_free(slab);
}
+#ifdef PERL_DEBUG_READONLY_OPS
OP *
Perl_op_refcnt_inc(pTHX_ OP *o)
{
if(o) {
- Slab_to_rw(o);
- ++o->op_targ;
+ OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+ if (slab && slab->opslab_readonly) {
+ Slab_to_rw(slab);
+ ++o->op_targ;
+ Slab_to_ro(slab);
+ } else {
+ ++o->op_targ;
+ }
}
return o;
PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP *o)
{
+ PADOFFSET result;
+ OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+
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;
- }
+ if (slab && slab->opslab_readonly) {
+ Slab_to_rw(slab);
+ result = --o->op_targ;
+ Slab_to_ro(slab);
+ } else {
+ result = --o->op_targ;
}
+ return result;
}
#endif
/*
o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC const char*
+STATIC SV*
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);
+ return tmpsv;
}
STATIC OP *
}
STATIC OP *
-S_too_few_arguments(pTHX_ OP *o, const char *name)
+S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+ SvUTF8(namesv) | flags);
+ return o;
+}
+
+STATIC OP *
+S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
+ return o;
+}
+
+STATIC OP *
+S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
- yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
return o;
}
STATIC OP *
-S_too_many_arguments(pTHX_ OP *o, const char *name)
+S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
- yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
+ SvUTF8(namesv) | flags);
return o;
}
STATIC void
-S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
{
- PERL_ARGS_ASSERT_BAD_TYPE;
+ PERL_ARGS_ASSERT_BAD_TYPE_PV;
- yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)));
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, OP_DESC(kid)), flags);
+}
+
+STATIC void
+S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+{
+ PERL_ARGS_ASSERT_BAD_TYPE_SV;
+
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
+ (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
}
STATIC void
if (len &&
!(is_our ||
isALPHA(name[1]) ||
- ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
- if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
+ if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
- PL_parser->in_my == KEY_state ? "state" : "my"));
+ yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
+ PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
return off;
}
+/*
+=for apidoc alloccopstash
+
+Available only under threaded builds, this function allocates an entry in
+C<PL_stashpad> for the stash passed to it.
+
+=cut
+*/
+
+#ifdef USE_ITHREADS
+PADOFFSET
+Perl_alloccopstash(pTHX_ HV *hv)
+{
+ PADOFFSET off = 0, o = 1;
+ bool found_slot = FALSE;
+
+ PERL_ARGS_ASSERT_ALLOCCOPSTASH;
+
+ if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
+
+ for (; o < PL_stashpadmax; ++o) {
+ if (PL_stashpad[o] == hv) return PL_stashpadix = o;
+ if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
+ found_slot = TRUE, off = o;
+ }
+ if (!found_slot) {
+ Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
+ Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
+ off = PL_stashpadmax;
+ PL_stashpadmax += 10;
+ }
+
+ PL_stashpad[PL_stashpadix = off] = hv;
+ return off;
+}
+#endif
+
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
static void
S_op_destroy(pTHX_ OP *o)
{
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
FreeOp(o);
}
dVAR;
OPCODE type;
- if (!o)
+ /* Though ops may be freed twice, freeing the op after its slab is a
+ big no-no. */
+ assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ /* During the forced freeing of ops after compilation failure, kidops
+ may be freed before their parents. */
+ if (!o || o->op_type == OP_FREED)
return;
- if (o->op_latefreed) {
- if (o->op_latefree)
- return;
- goto do_free;
- }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
CALL_OPFREEHOOK(o);
if (o->op_flags & OPf_KIDS) {
- register OP *kid, *nextkid;
+ OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
op_free(kid);
}
}
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
-#ifdef PERL_DEBUG_READONLY_OPS
- Slab_to_rw(o);
-#endif
+ if (o->op_slabbed) {
+ Slab_to_rw(OpSLAB(o));
+ }
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- 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))) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
-
op_clear(o);
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
- do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
}
#endif
break;
+ case OP_DUMP:
case OP_GOTO:
case OP_NEXT:
case OP_LAST:
case OP_TRANS:
case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+ assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
case OP_MATCH:
case OP_QR:
clear_pmop:
+ if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
+ op_free(cPMOPo->op_code_list);
+ cPMOPo->op_code_list = NULL;
forget_pmop(cPMOPo, 1);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
/* we use the same protection as the "SAFE" version of the PM_ macros
PERL_ARGS_ASSERT_COP_FREE;
CopFILE_free(cop);
- CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
PERL_ARGS_ASSERT_FORGET_PMOP;
- if (pmstash && !SvIS_FREED(pmstash)) {
+ if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
if (mg) {
PMOP **const array = (PMOP**) mg->mg_ptr;
/* establish postfix order */
first = cUNOPo->op_first;
if (first) {
- register OP *kid;
+ OP *kid;
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ if (PL_parser && PL_parser->copline != NOLINE) {
+ /* This ensures that warnings are reported at the first line
+ of the conditional, not the last. */
CopLINE_set(PL_curcop, PL_parser->copline);
+ }
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
{
dVAR;
OP *kid;
+ SV *useless_sv = NULL;
const char* useless = NULL;
- U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
strnEQ(maybe_macro, "ig", 2))
useless = NULL;
else {
- SV * const dsv = newSV(0);
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, maybe_macro,
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
SvREFCNT_dec(dsv);
- useless = SvPV_nolen(msv);
- useless_is_utf8 = SvUTF8(msv);
}
}
else if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
}
else
useless = "a constant (undef)";
case OP_SCALAR:
return scalar(o);
}
- if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
- newSVpvn_flags(useless, strlen(useless),
- SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
+
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ sv_2mortal(useless_sv));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
return o;
}
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
}
break;
}
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
}
}
break;
switch (o->op_type) {
case OP_UNDEF:
- localize = 0;
PL_modcount++;
return o;
case OP_STUB:
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
- OP *okid;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
break; /* Postpone until runtime */
}
- okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
if (type != OP_LEAVESUBLV)
goto nomod;
break; /* op_lvalue()ing was handled by ck_return() */
+
+ case OP_COREARGS:
+ return o;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
- assert(o || type != OP_SASSIGN);
-
switch (type) {
+ case OP_POS:
case OP_SASSIGN:
- if (o->op_type == OP_RV2GV)
+ if (o && o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
case OP_PREINC:
case OP_SCALAR:
case OP_NULL:
- if (!(o->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
break;
doref(cBINOPo->op_first, type, set_op_ref);
break;
}
STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
dVAR;
- SV *stashsv;
+ SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
PERL_ARGS_ASSERT_APPLY_ATTRS;
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
- stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
- if (for_my) {
- /* Don't force the C<use> if we don't need it. */
- SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
- if (svp && *svp != &PL_sv_undef)
- NOOP; /* already in %INC */
- else
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs(ATTRSMODULE), NULL);
- }
- else {
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
newSVpvs(ATTRSMODULE),
NULL,
op_prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0,
newRV(target)),
dup_attrlist(attrs))));
- }
LEAVE;
}
{
dVAR;
OP *pack, *imop, *arg;
- SV *meth, *stashsv;
+ SV *meth, *stashsv, **svp;
PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
target->op_type == OP_PADAV);
/* Ensure that attributes.pm is loaded. */
- apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
+ ENTER; /* need to protect against side-effects of 'use' */
+ /* Don't force the C<use> if we don't need it. */
+ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
+ if (svp && *svp != &PL_sv_undef)
+ NOOP; /* already in %INC */
+ else
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs(ATTRSMODULE), NULL);
+ LEAVE;
/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
- } else if (type == OP_UNDEF
-#ifdef PERL_MAD
- || type == OP_STUB
-#endif
- ) {
+ return o;
+ } else if (type == OP_UNDEF || type == OP_STUB) {
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
- attrs, FALSE);
+ attrs);
}
o->op_private |= OPpOUR_INTRO;
return o;
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, 0));
+ pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
}
OP *
return o;
}
+OP *
+Perl_op_unscope(pTHX_ OP *o)
+{
+ if (o && o->op_type == OP_LINESEQ) {
+ OP *kid = cLISTOPo->op_first;
+ for(; kid; kid = kid->op_sibling)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
+ }
+ return o;
+}
+
int
Perl_block_start(pTHX_ int full)
{
dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
+ OP *o;
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
- pad_leavemy();
+ o = pad_leavemy();
+
+ if (o) {
+ /* pad_leavemy has created a sequence of introcv ops for all my
+ subs declared in the block. We have to replicate that list with
+ clonecv ops, to deal with this situation:
+
+ sub {
+ my sub s1;
+ my sub s2;
+ sub s1 { state sub foo { \&s2 } }
+ }->()
+
+ Originally, I was going to have introcv clone the CV and turn
+ off the stale flag. Since &s1 is declared before &s2, the
+ introcv op for &s1 is executed (on sub entry) before the one for
+ &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
+ cloned, since it is a state sub) closes over &s2 and expects
+ to see it in its outer CV’s pad. If the introcv op clones &s1,
+ then &s2 is still marked stale. Since &s1 is not active, and
+ &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
+ ble will not stay shared’ warning. Because it is the same stub
+ that will be used when the introcv op for &s2 is executed, clos-
+ ing over it is safe. Hence, we have to turn off the stale flag
+ on all lexical subs in the block before we clone any of them.
+ Hence, having introcv clone the sub cannot work. So we create a
+ list of ops like this:
+
+ lineseq
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ .
+ .
+ .
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ .
+ .
+ .
+ */
+ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
+ OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
+ for (;; kid = kid->op_sibling) {
+ OP *newkid = newOP(OP_CLONECV, 0);
+ newkid->op_targ = kid->op_targ;
+ o = op_append_elem(OP_LINESEQ, o, newkid);
+ if (kid == last) break;
+ }
+ retval = op_prepend_elem(OP_LINESEQ, o, retval);
+ }
CALL_BLOCK_HOOKS(bhk_post_end, &retval);
if (PL_in_eval) {
PERL_CONTEXT *cx;
+ I32 i;
if (PL_eval_root)
return;
PL_eval_root = newUNOP(OP_LEAVEEVAL,
else
scalar(PL_eval_root);
- /* don't use LINKLIST, since PL_eval_root might indirect through
- * a rather expensive function call and LINKLIST evaluates its
- * argument more than once */
PL_eval_start = op_linklist(PL_eval_root);
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
+ i = PL_savestack_ix;
+ SAVEFREEOP(o);
+ ENTER;
CALL_PEEP(PL_eval_start);
finalize_optree(PL_eval_root);
-
+ LEAVE;
+ PL_savestack_ix = i;
}
else {
if (o->op_type == OP_STUB) {
+ /* This block is entered if nothing is compiled for the main
+ program. This will be the case for an genuinely empty main
+ program, or one which only has BEGIN blocks etc, so already
+ run and freed.
+
+ Historically (5.000) the guard above was !o. However, commit
+ f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
+ c71fccf11fde0068, changed perly.y so that newPROG() is now
+ called with the output of block_end(), which returns a new
+ OP_STUB for the case of an empty optree. ByteLoader (and
+ maybe other things) also take this path, because they set up
+ PL_main_start and PL_main_root directly, without generating an
+ optree.
+
+ If the parsing the main program aborts (due to parse errors,
+ or due to BEGIN or similar calling exit), then newPROG()
+ isn't even called, and hence this code path and its cleanups
+ are skipped. This shouldn't make a make a difference:
+ * a non-zero return from perl_parse is a failure, and
+ perl_destruct() should be called immediately.
+ * however, if exit(0) is called during the parse, then
+ perl_parse() returns 0, and perl_run() is called. As
+ PL_main_start will be NULL, perl_run() will return
+ promptly, and the exit code will remain 0.
+ */
+
PL_comppad_name = 0;
PL_compcv = 0;
S_op_destroy(aTHX_ o);
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
finalize_optree(PL_main_root);
+ cv_forget_slab(PL_compcv);
PL_compcv = 0;
/* Register with debugger */
PERL_ARGS_ASSERT_OP_INTEGERIZE;
- /* integerize op, unless it happens to be C<-foo>.
- * XXX should pp_i_negate() do magic string negation instead? */
- if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
- && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
- && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
+ /* integerize op. */
+ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
{
dVAR;
o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
S_fold_constants(pTHX_ register OP *o)
{
dVAR;
- register OP * VOL curop;
+ OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
if (IN_LOCALE_COMPILETIME)
goto nope;
break;
+ case OP_PACK:
+ if (!cLISTOPo->op_first->op_sibling
+ || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
+ goto nope;
+ {
+ SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
+ if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
+ {
+ const char *s = SvPVX_const(sv);
+ while (s < SvEND(sv)) {
+ if (*s == 'p' || *s == 'P') goto nope;
+ s++;
+ }
+ }
+ }
+ break;
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST) goto nope;
}
if (PL_parser && PL_parser->error_count)
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
op_getmad(o,newop,'f');
return newop;
S_gen_constant_list(pTHX_ register OP *o)
{
dVAR;
- register OP *curop;
+ OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
list(o);
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
- o->op_latefree = 0;
- o->op_latefreed = 0;
- o->op_attached = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const U8 *r = (U8*)SvPV_const(rstr, rlen);
- register I32 i;
- register I32 j;
+ I32 i;
+ I32 j;
I32 grows = 0;
- register short *tbl;
+ short *tbl;
const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
else
bits = 8;
- PerlMemShared_free(cPVOPo->op_pv);
- cPVOPo->op_pv = NULL;
-
swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
return o;
}
- tbl = (short*)cPVOPo->op_pv;
+ tbl = (short*)PerlMemShared_calloc(
+ (o->op_private & OPpTRANS_COMPLEMENT) &&
+ !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
+ sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
if (complement) {
- Zero(tbl, 256, short);
for (i = 0; i < (I32)tlen; i++)
tbl[t[i]] = -1;
for (i = 0, j = 0; i < 256; i++) {
* split "pattern", which aren't. In the former case, expr will be a list
* if the pattern contains more than one term (eg /a$b/) or if it contains
* a replacement, ie s/// or tr///.
+ *
+ * When the pattern has been compiled within a new anon CV (for
+ * qr/(?{...})/ ), then floor indicates the savestack level just before
+ * the new sub was created
*/
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
{
dVAR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
OP* repl = NULL;
- bool reglist;
+ bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+ bool is_compiletime;
+ bool has_code;
PERL_ARGS_ASSERT_PMRUNTIME;
- if (
- o->op_type == OP_SUBST
- || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
- ) {
- /* last element in list is the replacement; pop it */
+ /* for s/// and tr///, last element in list is the replacement; pop it */
+
+ if (is_trans || o->op_type == OP_SUBST) {
OP* kid;
repl = cLISTOPx(expr)->op_last;
kid = cLISTOPx(expr)->op_first;
cLISTOPx(expr)->op_last = kid;
}
- if (isreg && expr->op_type == OP_LIST &&
- cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
- {
- /* convert single element list to element */
+ /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
+
+ if (is_trans) {
OP* const oe = expr;
- expr = cLISTOPx(oe)->op_first->op_sibling;
+ assert(expr->op_type == OP_LIST);
+ assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
+ assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
+ expr = cLISTOPx(oe)->op_last;
cLISTOPx(oe)->op_first->op_sibling = NULL;
cLISTOPx(oe)->op_last = NULL;
op_free(oe);
- }
- if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
return pmtrans(o, expr, repl);
}
- reglist = isreg && expr->op_type == OP_LIST;
- if (reglist)
- op_null(expr);
-
- PL_hints |= HINT_BLOCK_SCOPE;
- pm = (PMOP*)o;
+ /* find whether we have any runtime or code elements;
+ * at the same time, temporarily set the op_next of each DO block;
+ * then when we LINKLIST, this will cause the DO blocks to be excluded
+ * from the op_next chain (and from having LINKLIST recursively
+ * applied to them). We fix up the DOs specially later */
+
+ is_compiletime = 1;
+ has_code = 0;
+ if (expr->op_type == OP_LIST) {
+ OP *o;
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
+ has_code = 1;
+ assert(!o->op_next && o->op_sibling);
+ o->op_next = o->op_sibling;
+ }
+ else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
+ is_compiletime = 0;
+ }
+ }
+ else if (expr->op_type != OP_CONST)
+ is_compiletime = 0;
- if (expr->op_type == OP_CONST) {
- SV *pat = ((SVOP*)expr)->op_sv;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ LINKLIST(expr);
- if (o->op_flags & OPf_SPECIAL)
- pm_flags |= RXf_SPLIT;
+ /* fix up DO blocks; treat each one as a separate little sub */
- 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);
+ if (expr->op_type == OP_LIST) {
+ OP *o;
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
+ continue;
+ o->op_next = NULL; /* undo temporary hack from above */
+ scalar(o);
+ LINKLIST(o);
+ if (cLISTOPo->op_first->op_type == OP_LEAVE) {
+ LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
+ /* skip ENTER */
+ assert(leave->op_first->op_type == OP_ENTER);
+ assert(leave->op_first->op_sibling);
+ o->op_next = leave->op_first->op_sibling;
+ /* skip LEAVE */
+ assert(leave->op_flags & OPf_KIDS);
+ assert(leave->op_last->op_next = (OP*)leave);
+ leave->op_next = NULL; /* stop on last op */
+ op_null((OP*)leave);
+ }
+ else {
+ /* skip SCOPE */
+ OP *scope = cLISTOPo->op_first;
+ assert(scope->op_type == OP_SCOPE);
+ assert(scope->op_flags & OPf_KIDS);
+ scope->op_next = NULL; /* stop on last op */
+ op_null(scope);
+ }
+ /* have to peep the DOs individually as we've removed it from
+ * the op_next chain */
+ CALL_PEEP(o);
+ if (is_compiletime)
+ /* runtime finalizes as part of finalizing whole tree */
+ finalize_optree(o);
}
+ }
- PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+ PL_hints |= HINT_BLOCK_SCOPE;
+ pm = (PMOP*)o;
+ assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
+
+ if (is_compiletime) {
+ U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ regexp_engine const *eng = current_re_engine();
+
+ if (!has_code || !eng->op_comp) {
+ /* compile-time simple constant pattern */
+
+ if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
+ /* whoops! we guessed that a qr// had a code block, but we
+ * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
+ * that isn't required now. Note that we have to be pretty
+ * confident that nothing used that CV's pad while the
+ * regex was parsed */
+ assert(AvFILLp(PL_comppad) == 0); /* just @_ */
+ /* But we know that one op is using this CV's slab. */
+ cv_forget_slab(PL_compcv);
+ LEAVE_SCOPE(floor);
+ pm->op_pmflags &= ~PMf_HAS_CV;
+ }
+ PM_SETRE(pm,
+ eng->op_comp
+ ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ );
#ifdef PERL_MAD
- op_getmad(expr,(OP*)pm,'e');
+ op_getmad(expr,(OP*)pm,'e');
#else
- op_free(expr);
+ op_free(expr);
#endif
+ }
+ else {
+ /* compile-time pattern that includes literal code blocks */
+ REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags,
+ (pm->op_pmflags |
+ ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
+ );
+ PM_SETRE(pm, re);
+ if (pm->op_pmflags & PMf_HAS_CV) {
+ CV *cv;
+ /* this QR op (and the anon sub we embed it in) is never
+ * actually executed. It's just a placeholder where we can
+ * squirrel away expr in op_code_list without the peephole
+ * optimiser etc processing it for a second time */
+ OP *qr = newPMOP(OP_QR, 0);
+ ((PMOP*)qr)->op_code_list = expr;
+
+ /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
+ SvREFCNT_inc_simple_void(PL_compcv);
+ cv = newATTRSUB(floor, 0, NULL, NULL, qr);
+ ReANY(re)->qr_anoncv = cv;
+
+ /* attach the anon CV to the pad so that
+ * pad_fixup_inner_anons() can find it */
+ (void)pad_add_anon(cv, o->op_type);
+ SvREFCNT_inc_simple_void(cv);
+ }
+ else {
+ pm->op_code_list = expr;
+ }
+ }
}
else {
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
- expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
- ? OP_REGCRESET
- : OP_REGCMAYBE),0,expr);
+ /* runtime pattern: build chain of regcomp etc ops */
+ bool reglist;
+ PADOFFSET cv_targ = 0;
+
+ reglist = isreg && expr->op_type == OP_LIST;
+ if (reglist)
+ op_null(expr);
+
+ if (has_code) {
+ pm->op_code_list = expr;
+ /* don't free op_code_list; its ops are embedded elsewhere too */
+ pm->op_pmflags |= PMf_CODELIST_PRIVATE;
+ }
+
+ /* the OP_REGCMAYBE is a placeholder in the non-threaded case
+ * to allow its op_next to be pointed past the regcomp and
+ * preceding stacking ops;
+ * OP_REGCRESET is there to reset taint before executing the
+ * stacking ops */
+ if (pm->op_pmflags & PMf_KEEP || PL_tainting)
+ expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
+
+ if (pm->op_pmflags & PMf_HAS_CV) {
+ /* we have a runtime qr with literal code. This means
+ * that the qr// has been wrapped in a new CV, which
+ * means that runtime consts, vars etc will have been compiled
+ * against a new pad. So... we need to execute those ops
+ * within the environment of the new CV. So wrap them in a call
+ * to a new anon sub. i.e. for
+ *
+ * qr/a$b(?{...})/,
+ *
+ * we build an anon sub that looks like
+ *
+ * sub { "a", $b, '(?{...})' }
+ *
+ * and call it, passing the returned list to regcomp.
+ * Or to put it another way, the list of ops that get executed
+ * are:
+ *
+ * normal PMf_HAS_CV
+ * ------ -------------------
+ * pushmark (for regcomp)
+ * pushmark (for entersub)
+ * pushmark (for refgen)
+ * anoncode
+ * refgen
+ * entersub
+ * regcreset regcreset
+ * pushmark pushmark
+ * const("a") const("a")
+ * gvsv(b) gvsv(b)
+ * const("(?{...})") const("(?{...})")
+ * leavesub
+ * regcomp regcomp
+ */
+
+ SvREFCNT_inc_simple_void(PL_compcv);
+ /* these lines are just an unrolled newANONATTRSUB */
+ expr = newSVOP(OP_ANONCODE, 0,
+ MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
+ cv_targ = expr->op_targ;
+ expr = newUNOP(OP_REFGEN, 0, expr);
+
+ expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
+ }
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_REGCOMP;
rcop->op_flags |= OPf_KIDS
| ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
- rcop->op_private = 1;
+ rcop->op_private = 0;
rcop->op_other = o;
- if (reglist)
- rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+ rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
/* establish postfix order */
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
+ if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
LINKLIST(expr);
rcop->op_next = expr;
((UNOP*)expr)->op_first->op_next = (OP*)rcop;
}
if (repl) {
- OP *curop;
+ OP *curop = repl;
+ bool konst;
if (pm->op_pmflags & PMf_EVAL) {
- curop = NULL;
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;
- else {
- OP *lastop = NULL;
- for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
- if (curop->op_type == OP_SCOPE
- || curop->op_type == OP_LEAVE
- || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
- if (curop->op_type == OP_GV) {
- GV * const gv = cGVOPx_gv(curop);
- repl_has_vars = 1;
- if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
- break;
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
- break;
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- repl_has_vars = 1;
- }
- else if (curop->op_type == OP_PUSHRE)
- NOOP; /* Okay here, dangerous in newASSIGNOP */
- else
- break;
- }
- lastop = curop;
- }
- }
- if (curop == repl
+ /* If we are looking at s//.../e with a single statement, get past
+ the implicit do{}. */
+ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
+ && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+ && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling
+ && !kid->op_sibling->op_sibling)
+ curop = kid->op_sibling;
+ }
+ if (curop->op_type == OP_CONST)
+ konst = TRUE;
+ else if (( (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV)
+ && cUNOPx(curop)->op_first
+ && cUNOPx(curop)->op_first->op_type == OP_GV )
+ || curop->op_type == OP_PADSV
+ || curop->op_type == OP_PADAV
+ || curop->op_type == OP_PADHV
+ || curop->op_type == OP_PADANY) {
+ repl_has_vars = 1;
+ konst = TRUE;
+ }
+ else konst = FALSE;
+ if (konst
&& !(repl_has_vars
&& (!PM_GETRE(pm)
+ || !RX_PRELEN(PM_GETRE(pm))
|| RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
- pm->op_pmflags |= PMf_MAYBE_CONST;
- }
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
+ svop->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)svop);
if (PL_opargs[type] & OA_TARGET)
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
dVAR;
+ const bool utf8 = cBOOL(flags & SVf_UTF8);
PVOP *pvop;
+ flags &= ~SVf_UTF8;
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
|| type == OP_RUNCV
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
+ pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)pvop);
if (PL_opargs[type] & OA_TARGET)
OP *imop;
OP *veop;
#ifdef PERL_MAD
- OP *pegop = newOP(OP_NULL,0);
+ OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
#endif
SV *use_version = NULL;
newSTATEOP(0, NULL, imop) ));
if (use_version) {
- HV * const hinthv = GvHV(PL_hintgv);
- const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
-
/* Enable the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
/* If a version >= 5.11.0 is requested, strictures are on by default! */
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
PL_hints |= HINT_STRICT_REFS;
- if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
PL_hints |= HINT_STRICT_SUBS;
- if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
PL_hints |= HINT_STRICT_VARS;
}
/* otherwise they are off */
else {
- if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
PL_hints &= ~HINT_STRICT_REFS;
- if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
PL_hints &= ~HINT_STRICT_SUBS;
- if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
PL_hints &= ~HINT_STRICT_VARS;
}
}
PL_cop_seqmax++;
#ifdef PERL_MAD
- if (!PL_madskills) {
- /* FIXME - don't allocate pegop if !PL_madskills */
- op_free(pegop);
- return NULL;
- }
return pegop;
#endif
}
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv))))));
+ newGVOP(OP_GV, 0, gv)))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
{
dVAR;
const U32 seq = intro_my();
- register COP *cop;
+ const U32 utf8 = flags & SVf_UTF8;
+ COP *cop;
+
+ flags &= ~SVf_UTF8;
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
- Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
-
+ Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
+
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
CopLINE_set(cop, CopLINE(PL_curcop));
else {
CopLINE_set(cop, PL_parser->copline);
- if (PL_parser)
- PL_parser->copline = NOLINE;
+ PL_parser->copline = NOLINE;
}
#ifdef USE_ITHREADS
CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
+ else if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_FOLDED;
return other;
}
else {
}
if (warnop) {
const line_t oldline = CopLINE(PL_curcop);
+ /* This ensures that warnings are reported at the first line
+ of the construction, not the last. */
CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
|| live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
+ else if (live->op_type == OP_CONST)
+ live->op_private |= OPpCONST_FOLDED;
return live;
}
NewOp(1101, logop, 1, LOGOP);
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
- op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
- return NULL; /* listop already freed by new_logop */
+ return expr; /* listop already freed by new_logop */
}
if (listop)
((LISTOP*)listop)->op_last->op_next =
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
loop->op_private = (U8)iterpflags;
-#ifdef PL_OP_SLAB_ALLOC
+ if (loop->op_slabbed
+ && DIFF(loop, OpSLOT(loop)->opslot_next)
+ < SIZE_TO_PSIZE(sizeof(LOOP)))
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
-#else
- loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#endif
+ else if (!loop->op_slabbed)
+ loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
if (madsv)
Constructs, checks, and returns a loop-exiting op (such as C<goto>
or C<last>). I<type> is the opcode. I<label> supplies the parameter
determining the target of the op; it is consumed by this function and
-become part of the constructed op tree.
+becomes part of the constructed op tree.
=cut
*/
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
dVAR;
- OP *o;
+ OP *o = NULL;
PERL_ARGS_ASSERT_NEWLOOPEX;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
- if (type != OP_GOTO || label->op_type == OP_CONST) {
+ if (type != OP_GOTO) {
/* "last()" means "last" */
- if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
o = newOP(type, OPf_SPECIAL);
- else {
- o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
- ? SvPV_nolen_const(((SVOP*)label)->op_sv)
- : ""));
}
-#ifdef PERL_MAD
- op_getmad(label,o,'L');
-#else
- op_free(label);
-#endif
}
else {
/* Check whether it's going to be a goto &function */
if (label->op_type == OP_ENTERSUB
&& !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
- o = newUNOP(type, OPf_STACKED, label);
}
+
+ /* Check for a constant argument */
+ if (label->op_type == OP_CONST) {
+ SV * const sv = ((SVOP *)label)->op_sv;
+ STRLEN l;
+ const char *s = SvPV_const(sv,l);
+ if (l == strlen(s)) {
+ o = newPVOP(type,
+ SvUTF8(((SVOP*)label)->op_sv),
+ savesharedpv(
+ SvPV_nolen_const(((SVOP*)label)->op_sv)));
+ }
+ }
+
+ /* If we have already created an op, we do not need the label. */
+ if (o)
+#ifdef PERL_MAD
+ op_getmad(label,o,'L');
+#else
+ op_free(label);
+#endif
+ else o = newUNOP(type, OPf_STACKED, label);
+
PL_hints |= HINT_BLOCK_SCOPE;
return o;
}
variable, and I<block> supplies the body of the C<given> construct; they
are consumed by this function and become part of the constructed op tree.
I<defsv_off> is the pad offset of the scalar lexical variable that will
-be affected.
+be affected. If it is 0, the global $_ will be used.
=cut
*/
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
- const char * const cvp = CvPROTO(cv);
+ const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
const STRLEN clen = CvPROTOLEN(cv);
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
SV* name = NULL;
if (gv)
+ {
+ if (isGV(gv))
gv_efullname3(name = sv_newmortal(), gv, NULL);
+ else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
+ name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
+ SvUTF8(gv)|SVs_TEMP);
+ else name = (SV *)gv;
+ }
sv_setpvs(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
- if (SvPOK(cv))
+ if (cvp)
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
);
*
* We have just cloned an anon prototype that was marked as a const
* candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. Return the value.
+ * PADSV, ignore it if it has multiple references. In this case we
+ * return a newly created *copy* of the value.
*/
SV *
return sv;
}
-#ifdef PERL_MAD
-OP *
-#else
-void
-#endif
+CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
-#if 0
- /* This would be the return value, but the return cannot be reached. */
- OP* pegop = newOP(OP_NULL, 0);
+ dVAR;
+ CV **spot;
+ SV **svspot;
+ const char *ps;
+ STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+ U32 ps_utf8 = 0;
+ register CV *cv = NULL;
+ register CV *compcv = PL_compcv;
+ SV *const_sv;
+ PADNAME *name;
+ PADOFFSET pax = o->op_targ;
+ CV *outcv = CvOUTSIDE(PL_compcv);
+ CV *clonee = NULL;
+ HEK *hek = NULL;
+ bool reusable = FALSE;
+
+ PERL_ARGS_ASSERT_NEWMYSUB;
+
+ /* Find the pad slot for storing the new sub.
+ We cannot use PL_comppad, as it is the pad owned by the new sub. We
+ need to look in CvOUTSIDE and find the pad belonging to the enclos-
+ ing sub. And then we need to dig deeper if this is a lexical from
+ outside, as in:
+ my sub foo; sub { sub foo { } }
+ */
+ redo:
+ name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+ if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+ pax = PARENT_PAD_INDEX(name);
+ outcv = CvOUTSIDE(outcv);
+ assert(outcv);
+ goto redo;
+ }
+ svspot =
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+ [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
+ spot = (CV **)svspot;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+ }
+ else
+ ps = NULL;
+
+ if (!PL_madskills) {
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ }
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ goto done;
+ }
+
+ if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = *spot;
+ svspot = (SV **)(spot = &clonee);
+ }
+ else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
+ cv = *spot;
+ else {
+ MAGIC *mg;
+ SvUPGRADE(name, SVt_PVMG);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ assert (SvTYPE(*spot) == SVt_PVCV);
+ if (CvNAMED(*spot))
+ hek = CvNAME_HEK(*spot);
+ else {
+ CvNAME_HEK_set(*spot, hek =
+ share_hek(
+ PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ )
+ );
+ }
+ if (mg) {
+ assert(mg->mg_obj);
+ cv = (CV *)mg->mg_obj;
+ }
+ else {
+ sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ }
+ spot = (CV **)(svspot = &mg->mg_obj);
+ }
+
+ if (!block || !ps || *ps || attrs
+ || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
#endif
+ )
+ const_sv = NULL;
+ else
+ const_sv = op_const_sv(block, NULL);
- PERL_UNUSED_ARG(floor);
+ if (cv) {
+ const bool exists = CvROOT(cv) || CvXSUB(cv);
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- if (block)
- SAVEFREEOP(block);
- Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+ /* if the subroutine doesn't exist and wasn't pre-declared
+ * with a prototype, assume it will be AUTOLOADed,
+ * skipping the prototype check
+ */
+ if (exists || SvPOK(cv))
+ cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
+ /* already defined? */
+ if (exists) {
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
+ if (CvFLAGS(compcv)) {
+ /* might have had built-in attrs applied */
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ CvFLAGS(cv) |=
+ (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
+ }
+ if (attrs) goto attrs;
+ /* just a "sub foo;" when &foo is already defined */
+ SAVEFREESV(compcv);
+ goto done;
+ }
+ else {
+ /* redundant check that avoids creating the extra SV
+ most of the time: */
+ if (const_sv || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *noamp = sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1,
+ PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ report_redefined_cv(noamp, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
+ }
#ifdef PERL_MAD
- NORETURN_FUNCTION_END;
+ if (!PL_minus_c) /* keep old one around for madskills */
#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ cv = NULL;
+ }
+ }
+ else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = NULL;
+ reusable = TRUE;
+ }
+ }
+ if (const_sv) {
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ if (cv) {
+ assert(!CvROOT(cv) && !CvCONST(cv));
+ cv_forget_slab(cv);
+ }
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ *spot = cv;
+ }
+ sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ CvXSUBANY(cv).any_ptr = const_sv;
+ CvXSUB(cv) = const_sv_xsub;
+ CvCONST_on(cv);
+ CvISXSUB_on(cv);
+ if (PL_madskills)
+ goto install_block;
+ op_free(block);
+ SvREFCNT_dec(compcv);
+ PL_compcv = NULL;
+ goto clone;
+ }
+ /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
+ determine whether this sub definition is in the same scope as its
+ declaration. If this sub definition is inside an inner named pack-
+ age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
+ the package sub. So check PadnameOUTER(name) too.
+ */
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ assert(!CvWEAKOUTSIDE(compcv));
+ SvREFCNT_dec(CvOUTSIDE(compcv));
+ CvWEAKOUTSIDE_on(compcv);
+ }
+ /* XXX else do we have a circular reference? */
+ if (cv) { /* must reuse cv in case stub is referenced elsewhere */
+ /* transfer PL_compcv to cv */
+ if (block
+#ifdef PERL_MAD
+ && block->op_type != OP_NULL
+#endif
+ ) {
+ cv_flags_t preserved_flags =
+ CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
+ PADLIST *const temp_padl = CvPADLIST(cv);
+ CV *const temp_cv = CvOUTSIDE(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+ OP * const cvstart = CvSTART(cv);
+
+ SvPOK_off(cv);
+ CvFLAGS(cv) =
+ CvFLAGS(compcv) | preserved_flags;
+ CvOUTSIDE(cv) = CvOUTSIDE(compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
+ CvPADLIST(cv) = CvPADLIST(compcv);
+ CvOUTSIDE(compcv) = temp_cv;
+ CvPADLIST(compcv) = temp_padl;
+ CvSTART(cv) = CvSTART(compcv);
+ CvSTART(compcv) = cvstart;
+ CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(compcv) |= other_flags;
+
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
+ Safefree(CvFILE(cv));
+ }
+
+ /* inner references to compcv must be fixed up ... */
+ pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
+ }
+ else {
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
+ }
+ /* ... before we throw it away */
+ SvREFCNT_dec(compcv);
+ PL_compcv = compcv = cv;
+ }
+ else {
+ cv = compcv;
+ *spot = cv;
+ }
+ if (!CvNAME_HEK(cv)) {
+ CvNAME_HEK_set(cv,
+ hek
+ ? share_hek_hek(hek)
+ : share_hek(PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+ 0)
+ );
+ }
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
+
+ install_block:
+ if (!block)
+ goto attrs;
+
+ /* 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++;
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ OP* const newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+ op_getmad(block,newblock,'B');
+#else
+ op_free(block);
+#endif
+ block = newblock;
+ }
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv)->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(CvROOT(cv), 1);
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ CALL_PEEP(CvSTART(cv));
+ finalize_optree(CvROOT(cv));
+
+ /* now that optimizer has done its work, adjust pad values */
+
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+
+ if (CvCLONE(cv)) {
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
+ }
+
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
+ }
+
+ if (block) {
+ if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
+ SV * const tmpstr = sv_newmortal();
+ GV * const db_postponed = gv_fetchpvs("DB::postponed",
+ GV_ADDMULTI, SVt_PVHV);
+ HV *hv;
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+ CopFILE(PL_curcop),
+ (long)PL_subline,
+ (long)CopLINE(PL_curcop));
+ if (HvNAME_HEK(PL_curstash)) {
+ sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
+ sv_catpvs(tmpstr, "::");
+ }
+ else sv_setpvs(tmpstr, "__ANON__::");
+ sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
+ PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
+ hv = GvHVn(db_postponed);
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
+ CV * const pcv = GvCV(db_postponed);
+ if (pcv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ call_sv(MUTABLE_SV(pcv), G_DISCARD);
+ }
+ }
+ }
+ }
+
+ clone:
+ if (clonee) {
+ assert(CvDEPTH(outcv));
+ spot = (CV **)
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
+ if (reusable) cv_clone_into(clonee, *spot);
+ else *spot = cv_clone(clonee);
+ SvREFCNT_dec(clonee);
+ cv = *spot;
+ SvPADMY_on(cv);
+ }
+ if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
+ PADOFFSET depth = CvDEPTH(outcv);
+ while (--depth) {
+ SV *oldcv;
+ svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
+ oldcv = *svspot;
+ *svspot = SvREFCNT_inc_simple_NN(cv);
+ SvREFCNT_dec(oldcv);
+ }
+ }
+
+ done:
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ if (o) op_free(o);
+ return cv;
}
CV *
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- register CV *cv = NULL;
+ CV *cv = NULL;
SV *const_sv;
+ const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
full GV and CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
- = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ = ec ? GV_NOADD_NOINIT :
+ (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
if (proto) {
assert(proto->op_type == OP_CONST);
SAVEFREEOP(attrs);
}
+ if (ec) {
+ op_free(block);
+ if (name && block) {
+ const char *s = strrchr(name, ':');
+ s = s ? s+1 : name;
+ if (strEQ(s, "BEGIN")) {
+ const char not_safe[] =
+ "BEGIN not safe after errors--compilation aborted";
+ if (PL_in_eval & EVAL_KEEPERR)
+ Perl_croak(aTHX_ not_safe);
+ else {
+ /* force display of errors found but not reported */
+ sv_catpv(ERRSV, not_safe);
+ Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+ }
+ }
+ }
+ cv = PL_compcv;
+ goto done;
+ }
+
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((const SV *)gv)
- && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
- {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
- }
- cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8);
}
if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
#endif
) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ if (PL_parser && PL_parser->copline != NOLINE) {
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
CopLINE_set(PL_curcop, PL_parser->copline);
+ }
report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
CopLINE_set(PL_curcop, oldline);
#ifdef PERL_MAD
}
}
if (const_sv) {
- HV *stash;
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
+ cv_forget_slab(cv);
sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
const_sv
);
}
- stash =
- (CvGV(cv) && GvSTASH(CvGV(cv)))
- ? GvSTASH(CvGV(cv))
- : CvSTASH(cv)
- ? CvSTASH(cv)
- : PL_curstash;
- if (HvENAME_HEK(stash))
- mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
if (PL_madskills)
goto install_block;
op_free(block);
#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
- AV *const temp_av = CvPADLIST(cv);
+ PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+ OP * const cvstart = CvSTART(cv);
- assert(!CvWEAKOUTSIDE(cv));
+ CvGV_set(cv,gv);
assert(!CvCVGV_RC(cv));
assert(CvGV(cv) == gv);
CvPADLIST(cv) = CvPADLIST(PL_compcv);
CvOUTSIDE(PL_compcv) = temp_cv;
CvPADLIST(PL_compcv) = temp_av;
+ CvSTART(cv) = CvSTART(PL_compcv);
+ CvSTART(PL_compcv) = cvstart;
+ CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(PL_compcv) |= other_flags;
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
cv = PL_compcv;
if (name) {
GvCV_set(gv, cv);
- if (PL_madskills) {
- if (strEQ(name, "import")) {
- PL_formfeed = MUTABLE_SV(cv);
- /* diag_listed_as: SKIPME */
- Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
- }
- }
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- if (PL_parser && PL_parser->error_count) {
- op_free(block);
- block = NULL;
- if (name) {
- const char *s = strrchr(name, ':');
- s = s ? s+1 : name;
- if (strEQ(s, "BEGIN")) {
- const char not_safe[] =
- "BEGIN not safe after errors--compilation aborted";
- if (PL_in_eval & EVAL_KEEPERR)
- Perl_croak(aTHX_ not_safe);
- else {
- /* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
- }
- }
- }
- }
install_block:
if (!block)
goto attrs;
#endif
block = newblock;
}
- else block->op_attached = 1;
CvROOT(cv) = CvLVALUE(cv)
? newUNOP(OP_LEAVESUBLV, 0,
op_lvalue(scalarseq(block), OP_LEAVESUBLV))
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
+#endif
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
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);
+ apply_attrs(stash, MUTABLE_SV(cv), attrs);
}
if (block && has_name) {
}
if (name && ! (PL_parser && PL_parser->error_count))
- process_special_blocks(name, gv, cv);
+ process_special_blocks(floor, name, gv, cv);
}
done:
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* Watch out for BEGIN blocks */
+ if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+#endif
return cv;
}
STATIC void
-S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
+ GV *const gv,
CV *const cv)
{
const char *const colon = strrchr(fullname,':');
if (*name == 'B') {
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
+ if (floor) LEAVE_SCOPE(floor);
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
Currently, the only useful value for C<flags> is SVf_UTF8.
+The newly created subroutine takes ownership of a reference to the passed in
+SV.
+
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
if (stash) {
SAVEGENERICSV(PL_curstash);
- SAVECOPSTASH(PL_curcop);
PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
- CopSTASH_set(PL_curcop,stash);
}
/* file becomes the CvFILE. For an XS, it's usually static storage,
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
-#ifdef USE_ITHREADS
- if (stash)
- CopSTASH_free(PL_curcop);
-#endif
LEAVE;
return cv;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
{
- GV * const gv = name
- ? gv_fetchpvn(
- name,len,GV_ADDMULTI|flags,SVt_PVCV
- )
- : gv_fetchpv(
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI | flags, SVt_PVCV);
+ GV * const gv = gv_fetchpvn(
+ name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
+ name ? len : PL_curstash ? sizeof("__ANON__") - 1:
+ sizeof("__ANON__::__ANON__") - 1,
+ GV_ADDMULTI | flags, SVt_PVCV);
if (!subaddr)
Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
/* Redundant check that allows us to avoid creating an SV
most of the time: */
if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
report_redefined_cv(newSVpvn_flags(
name,len,(flags&SVf_UTF8)|SVs_TEMP
),
cv, const_svp);
- CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
cv = NULL;
CvXSUB(cv) = subaddr;
if (name)
- process_special_blocks(name, gv, cv);
+ process_special_blocks(0, name, gv, cv);
}
if (flags & XS_DYNAMIC_FILENAME) {
return cv;
}
+CV *
+Perl_newSTUB(pTHX_ GV *gv, bool fake)
+{
+ CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ PERL_ARGS_ASSERT_NEWSTUB;
+ assert(!GvCVu(gv));
+ GvCV_set(gv, cv);
+ GvCVGEN(gv) = 0;
+ if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv));
+ CvGV_set(cv, gv);
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ GvMULTI_on(gv);
+ return cv;
+}
+
/*
=for apidoc U||newXS
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
PERL_ARGS_ASSERT_NEWXS;
- return newXS_flags(name, subaddr, filename, NULL, 0);
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
}
#ifdef PERL_MAD
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
dVAR;
- register CV *cv;
+ CV *cv;
#ifdef PERL_MAD
OP* pegop = newOP(OP_NULL, 0);
#endif
- GV * const gv = o
+ GV *gv;
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ goto finish;
+ }
+
+ gv = o
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
SvREFCNT_dec(cv);
}
cv = PL_compcv;
- GvFORM(gv) = cv;
+ GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ cv_forget_slab(cv);
+
+ finish:
#ifdef PERL_MAD
op_getmad(o,pegop,'n');
op_getmad_weak(block, pegop, 'b');
OP *
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
+ if (o->op_type == OP_PADANY) {
+ dVAR;
+ o->op_type = OP_PADCV;
+ o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ return o;
+ }
return newUNOP(OP_RV2CV, flags, scalar(o));
}
MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
-
- if (!(o->op_private & OPpEVAL_BYTES)
+ }
+ if (!(o->op_private & OPpEVAL_BYTES)
&& FEATURE_UNIEVAL_IS_ENABLED)
o->op_private |= OPpEVAL_UNICODE;
- }
return o;
}
SVOP * const kid = (SVOP*)cUNOPo->op_first;
const OPCODE kidtype = kid->op_type;
- if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
+ && !(kid->op_private & OPpCONST_FOLDED)) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
{
dVAR;
const int type = o->op_type;
- register I32 oa = PL_opargs[type] >> OASHIFT;
+ I32 oa = PL_opargs[type] >> OASHIFT;
PERL_ARGS_ASSERT_CK_FUN;
if (o->op_flags & OPf_KIDS) {
OP **tokid = &cLISTOPo->op_first;
- register OP *kid = cLISTOPo->op_first;
+ OP *kid = cLISTOPo->op_first;
OP *sibl;
I32 numargs = 0;
bool seen_optional = FALSE;
if (numargs == 1 && !(oa >> 4)
&& kid->op_type == OP_LIST && type != OP_SCALAR)
{
- return too_many_arguments(o,PL_op_desc[type]);
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
}
scalar(kid);
break;
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
- bad_type(numargs, "array", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
*tokid = kid;
}
else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type(numargs, "hash", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
op_lvalue(kid, type);
break;
case OA_CVREF:
{
OP * const newop = newUNOP(OP_NULL, 0, kid);
kid->op_sibling = 0;
- LINKLIST(kid);
newop->op_next = newop;
kid = newop;
kid->op_sibling = sibl;
}
else if (kid->op_type == OP_READLINE) {
/* neophyte patrol: open(<FH>), close(<FH>) etc. */
- bad_type(numargs, "HANDLE", OP_DESC(o), kid);
+ bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
}
else {
I32 flags = OPf_SPECIAL;
scalar(kid);
break;
case OA_SCALARREF:
+ if ((type == OP_UNDEF || type == OP_POS)
+ && numargs == 1 && !(oa >> 4)
+ && kid->op_type == OP_LIST)
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
op_lvalue(scalar(kid), type);
break;
}
}
#ifdef PERL_MAD
if (kid && kid->op_type != OP_STUB)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
o->op_private |= numargs;
#else
/* FIXME - should the numargs move as for the PERL_MAD case? */
o->op_private |= numargs;
if (kid)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
#endif
listkids(o);
}
while (oa & OA_OPTIONAL)
oa >>= 4;
if (oa && oa != OA_LIST)
- return too_few_arguments(o,OP_DESC(o));
+ return too_few_arguments_pv(o,OP_DESC(o), 0);
}
return o;
}
else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ GV * const * const gvp =
+ (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
+ gv = gvp ? *gvp : NULL;
}
-#if !defined(PERL_EXTERNAL_GLOB)
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs("File::Glob"), NULL, NULL, NULL);
- LEAVE;
- }
-#endif /* !PERL_EXTERNAL_GLOB */
-
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
op_append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
- o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
else o->op_flags &= ~OPf_SPECIAL;
+#if !defined(PERL_EXTERNAL_GLOB)
+ if (!PL_globhook) {
+ ENTER;
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs("File::Glob"), NULL, NULL, NULL);
+ LEAVE;
+ }
+#endif /* !PERL_EXTERNAL_GLOB */
gv = newGVgen("main");
gv_IOadd(gv);
#ifndef PERL_EXTERNAL_GLOB
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop = NULL;
+ LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
PADOFFSET offset;
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
- OP* k;
- o = ck_sort(o);
kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
return no_fh_allowed(o);
- for (k = kid; k; k = k->op_next) {
- kid = k;
- }
- NewOp(1101, gwop, 1, LOGOP);
- kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
kid = cLISTOPo->op_first->op_sibling;
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- if (!gwop)
- NewOp(1101, gwop, 1, LOGOP);
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
- gwop->op_first = listkids(o);
+ gwop->op_first = o;
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
}
kid = cLISTOPo->op_first->op_sibling;
- if (!kid || !kid->op_sibling)
- return too_few_arguments(o,OP_DESC(o));
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_GREPSTART);
OP *
Perl_ck_listiob(pTHX_ OP *o)
{
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_LISTIOB;
if (kid && o->op_flags & OPf_STACKED)
kid = kid->op_sibling;
else if (kid && !kid->op_sibling) { /* print HANDLE; */
- if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
+ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
+ && !(kid->op_private & OPpCONST_FOLDED)) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
cLISTOPo->op_first->op_sibling = kid;
#ifndef PERL_MAD
op_free(o);
#endif
- newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, kid,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0,
- gv))))));
+ gv)))));
op_getmad(o,newop,'O');
return newop;
}
{
dVAR;
OP *firstkid;
+ HV * const hinthv = GvHV(PL_hintgv);
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) {
+ if (hinthv) {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
}
- }
}
- if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
- OP *k = NULL;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
LINKLIST(kid);
- if (kid->op_type == OP_SCOPE) {
- k = kid->op_next;
- kid->op_next = 0;
- }
- else if (kid->op_type == OP_LEAVE) {
- if (o->op_type == OP_SORT) {
+ if (kid->op_type == OP_LEAVE)
op_null(kid); /* wipe out leave */
- kid->op_next = kid;
-
- for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
- if (k->op_next == kid)
- k->op_next = 0;
- /* don't descend into loops */
- else if (k->op_type == OP_ENTERLOOP
- || k->op_type == OP_ENTERITER)
- {
- k = cLOOPx(k)->op_lastop;
- }
- }
- }
- else
- kid->op_next = 0; /* just disconnect the leave */
- k = kLISTOP->op_first;
- }
- CALL_PEEP(k);
+ /* Prevent execution from escaping out of the sort block. */
+ kid->op_next = 0;
- kid = firstkid;
- if (o->op_type == OP_SORT) {
- /* provide scalar context for comparison function/block */
- kid = scalar(kid);
- kid->op_next = kid;
- }
- else
- kid->op_next = k;
+ /* provide scalar context for comparison function/block */
+ kid = scalar(firstkid);
+ kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
}
/* provide list context for arguments */
- if (o->op_type == OP_SORT)
- list(firstkid);
+ list(firstkid);
return o;
}
S_simplify_sort(pTHX_ OP *o)
{
dVAR;
- register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int descending;
GV *gv;
const char *gvname;
+ bool have_scopeop;
PERL_ARGS_ASSERT_SIMPLIFY_SORT;
GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
- if (kid->op_type != OP_SCOPE)
+ if (!(have_scopeop = kid->op_type == OP_SCOPE)
+ && kid->op_type != OP_LEAVE)
return;
kid = kLISTOP->op_last; /* get past scope */
switch(kid->op_type) {
case OP_NCMP:
case OP_I_NCMP:
case OP_SCMP:
+ if (!have_scopeop) goto padkids;
break;
default:
return;
}
k = kid; /* remember this node*/
- if (kBINOP->op_first->op_type != OP_RV2SV)
+ if (kBINOP->op_first->op_type != OP_RV2SV
+ || kBINOP->op_last ->op_type != OP_RV2SV)
+ {
+ /*
+ Warn about my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
+ padkids:
+ if (!ckWARN(WARN_SYNTAX)) return;
+ kid = kBINOP->op_first;
+ do {
+ if (kid->op_type == OP_PADSV) {
+ SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
+ if (SvCUR(name) == 2 && *SvPVX(name) == '$'
+ && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
+ /* diag_listed_as: "my %s" used in sort comparison */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "\"%s %s\" used in sort comparison",
+ SvPAD_STATE(name) ? "state" : "my",
+ SvPVX(name));
+ }
+ } while ((kid = kid->op_sibling));
return;
+ }
kid = kBINOP->op_first; /* get past cmp */
if (kUNOP->op_first->op_type != OP_GV)
return;
return;
kid = k; /* back to cmp */
- if (kBINOP->op_last->op_type != OP_RV2SV)
- return;
+ /* already checked above that it is rv2sv */
kid = kBINOP->op_last; /* down to 2nd arg */
if (kUNOP->op_first->op_type != OP_GV)
return;
Perl_ck_split(pTHX_ OP *o)
{
dVAR;
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_SPLIT;
cLISTOPo->op_last = kid; /* There was only one element previously */
}
+ if (kid->op_type == OP_CONST && !(kid->op_private & OPpCONST_FOLDED)) {
+ SV * const sv = kSVOP->op_sv;
+ if (SvPOK(sv) && SvCUR(sv) == 1 && *SvPVX(sv) == ' ')
+ o->op_flags |= OPf_SPECIAL;
+ }
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, 0), kid, 0, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
return o;
}
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
- const STRLEN len = re ? RX_PRELEN(re) : 6;
+ const SV *msg = re
+ ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
+ SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
+ : newSVpvs_flags( "STRING", SVs_TEMP );
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%.*s/ should probably be written as \"%.*s\"",
- (int)len, pmstr, (int)len, pmstr);
+ "/%"SVf"/ should probably be written as \"%"SVf"\"",
+ SVfARG(msg), SVfARG(msg));
}
}
return ck_fun(o);
cv = (CV*)SvRV(rv);
gv = NULL;
} break;
+ case OP_PADCV: {
+ PADNAME *name = PAD_COMPNAME(rvop->op_targ);
+ CV *compcv = PL_compcv;
+ PADOFFSET off = rvop->op_targ;
+ while (PadnameOUTER(name)) {
+ assert(PARENT_PAD_INDEX(name));
+ compcv = CvOUTSIDE(PL_compcv);
+ name = PadlistNAMESARRAY(CvPADLIST(compcv))
+ [off = PARENT_PAD_INDEX(name)];
+ }
+ assert(!PadnameIsOUR(name));
+ if (!PadnameIsSTATE(name)) {
+ MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+ assert(mg);
+ assert(mg->mg_obj);
+ cv = (CV *)mg->mg_obj;
+ }
+ else cv =
+ (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+ gv = NULL;
+ } break;
default: {
return NULL;
} break;
const char *e = NULL;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
- Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto,"
+ Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
"flags=%lx", (unsigned long) SvFLAGS(protosv));
if (SvTYPE(protosv) == SVt_PVCV)
proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
o3 = aop;
if (proto >= proto_end)
- return too_many_arguments(entersubop, gv_ename(namegv));
+ return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
switch (*proto) {
case ';':
continue;
case '_':
/* _ must be at the end */
- if (proto[1] && proto[1] != ';')
+ if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
case '$':
proto++;
proto++;
arg++;
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
- bad_type(arg,
+ bad_type_sv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
} else
goto oops;
break;
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o3);
+ bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
break;
case '&':
if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv),
+ bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
o3);
break;
case '$':
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type(arg, "scalar", gv_ename(namegv), o3);
+ bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
}
break;
case '@':
o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o3);
+ bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o3);
+ bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
break;
wrapref:
{
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments(entersubop, gv_ename(namegv));
+ return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
return entersubop;
}
aop = aop->op_sibling;
}
if (aop != cvop)
- (void)too_many_arguments(entersubop, GvNAME(namegv));
+ (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
op_free(entersubop);
switch(GvNAME(namegv)[2]) {
#ifdef PERL_MAD
if (!PL_madskills || seenarg)
#endif
- (void)too_many_arguments(aop, GvNAME(namegv));
+ (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
op_free(aop);
}
return opnum == OP_RUNCV
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
+ callmg->mg_flags |= MGf_COPY;
}
}
Perl_call_checker ckfun;
SV *ckobj;
cv_get_call_checker(cv, &ckfun, &ckobj);
+ if (!namegv) { /* expletive! */
+ /* XXX The call checker API is public. And it guarantees that
+ a GV will be provided with the right name. So we have
+ to create a GV. But it is still not correct, as its
+ stringification will include the package. What we
+ really need is a new call checker API that accepts a
+ GV or string (or GV or CV). */
+ HEK * const hek = CvNAME_HEK(cv);
+ assert(hek);
+ namegv = (GV *)sv_newmortal();
+ gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+ SVf_UTF8 * !!HEK_UTF8(hek));
+ }
return ckfun(aTHX_ o, namegv, ckobj);
}
}
}
OP *
-Perl_ck_chdir(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_CHDIR;
- if (o->op_flags & OPf_KIDS) {
- SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- o->op_flags |= OPf_SPECIAL;
- kid->op_private &= ~OPpCONST_STRICT;
- }
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_trunc(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_TRUNC;
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
+ (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
+ == OPpCONST_BARE)
{
o->op_flags |= OPf_SPECIAL;
kid->op_private &= ~OPpCONST_STRICT;
return o;
}
-/* caller is supposed to assign the return to the
- container of the rep_op var */
-STATIC OP *
-S_opt_scalarhv(pTHX_ OP *rep_op) {
- dVAR;
- UNOP *unop;
-
- PERL_ARGS_ASSERT_OPT_SCALARHV;
-
- NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)OP_BOOLKEYS;
- unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
- unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
- unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
- unop->op_first = rep_op;
- unop->op_next = rep_op->op_next;
- rep_op->op_next = (OP*)unop;
- rep_op->op_flags|=(OPf_REF | OPf_MOD);
- unop->op_sibling = rep_op->op_sibling;
- rep_op->op_sibling = NULL;
- /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
- if (rep_op->op_type == OP_PADHV) {
- rep_op->op_flags &= ~OPf_WANT_SCALAR;
- rep_op->op_flags |= OPf_WANT_LIST;
- }
- return (OP*)unop;
-}
-
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
#define MAX_DEFERRED 4
#define DEFER(o) \
+ STMT_START { \
if (defer_ix == (MAX_DEFERRED-1)) { \
CALL_RPEEP(defer_queue[defer_base]); \
defer_base = (defer_base + 1) % MAX_DEFERRED; \
defer_ix--; \
} \
- defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
+ } STMT_END
/* 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
Perl_rpeep(pTHX_ register OP *o)
{
dVAR;
- register OP* oldop = NULL;
+ OP* oldop = NULL;
OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
data. */
firstcop->cop_line = secondcop->cop_line;
#ifdef USE_ITHREADS
- firstcop->cop_stashpv = secondcop->cop_stashpv;
+ firstcop->cop_stashoff = secondcop->cop_stashoff;
firstcop->cop_file = secondcop->cop_file;
#else
firstcop->cop_stash = secondcop->cop_stash;
firstcop->cop_hints_hash = secondcop->cop_hints_hash;
#ifdef USE_ITHREADS
- secondcop->cop_stashpv = NULL;
+ secondcop->cop_stashoff = 0;
secondcop->cop_file = NULL;
#else
secondcop->cop_stash = NULL;
OP *fop;
OP *sop;
+#define HV_OR_SCALARHV(op) \
+ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
+ ? (op) \
+ : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
+ && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
+ || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
+ ? cUNOPx(op)->op_first \
+ : NULL)
+
case OP_NOT:
- fop = cUNOP->op_first;
- sop = NULL;
- goto stitch_keys;
+ if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
+ fop->op_private |= OPpTRUEBOOL;
break;
case OP_AND:
o->op_next = o->op_next->op_next;
DEFER(cLOGOP->op_other);
- stitch_keys:
o->op_opt = 1;
- if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- || ( sop &&
- (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
- )
+ fop = HV_OR_SCALARHV(fop);
+ if (sop) sop = HV_OR_SCALARHV(sop);
+ if (fop || sop
){
OP * nop = o;
OP * lop = o;
}
}
}
- if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
- if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- cLOGOP->op_first = opt_scalarhv(fop);
- if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
- cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
- }
+ if (fop) {
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ || o->op_type == OP_AND )
+ fop->op_private |= OPpTRUEBOOL;
+ else if (!(lop->op_flags & OPf_WANT))
+ fop->op_private |= OPpMAYBE_TRUEBOOL;
+ }
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && sop)
+ sop->op_private |= OPpTRUEBOOL;
}
break;
- }
+ case OP_COND_EXPR:
+ if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
+ fop->op_private |= OPpTRUEBOOL;
+#undef HV_OR_SCALARHV
+ /* GERONIMO! */
+ }
+
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
- case OP_COND_EXPR:
case OP_RANGE:
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
break;
case OP_SORT: {
+ OP *oright;
+
+ if (o->op_flags & OPf_STACKED) {
+ OP * const kid =
+ cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
+ if (kid->op_type == OP_SCOPE
+ || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
+ DEFER(kLISTOP->op_first);
+ }
+
/* check that RHS of sort is a single plain array */
- OP *oright = cUNOPo->op_first;
+ oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
case OP_RUNCV:
if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
SV *sv;
- if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
+ if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
sv = newRV((SV *)PL_compcv);
sv_rvweaken(sv);
This function assigns the prototype of the named core function to C<sv>, or
to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
NULL if the core function has no prototype. C<code> is a code as returned
-by C<keyword()>. It must be negative and unequal to -KEY_CORE.
+by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
=cut
*/
PERL_ARGS_ASSERT_CORE_PROTOTYPE;
- assert (code < 0 && code != -KEY_CORE);
+ assert (code && code != -KEY_CORE);
if (!sv) sv = sv_newmortal();
#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
- switch (-code) {
+ switch (code < 0 ? -code : code) {
case KEY_and : case KEY_chop: case KEY_chomp:
- case KEY_cmp : case KEY_exec: case KEY_eq :
- case KEY_ge : case KEY_gt : case KEY_le :
- case KEY_lt : case KEY_ne : case KEY_or :
- case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
+ case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
+ case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
+ case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
+ case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
+ case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
+ case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
+ case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
+ case KEY_x : case KEY_xor :
if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+ case KEY_glob: retsetpvs("_;", OP_GLOB);
case KEY_keys: retsetpvs("+", OP_KEYS);
case KEY_values: retsetpvs("+", OP_VALUES);
case KEY_each: retsetpvs("+", OP_EACH);
case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
case KEY_pop: retsetpvs(";+", OP_POP);
case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
case KEY_splice:
retsetpvs("+;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
}
i++;
}
- assert(0); return NULL; /* Should not happen... */
+ return NULL;
found:
defgv = PL_opargs[i] & OA_DEFGV;
oa = PL_opargs[i] >> OASHIFT;
str[n++] = '$';
str[n++] = '@';
str[n++] = '%';
- if (i == OP_LOCK) str[n++] = '&';
+ if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
str[n++] = '*';
str[n++] = ']';
}
onearg:
if (is_handle_constructor(o, 1))
argop->op_private |= OPpCOREARGS_DEREF1;
+ if (scalar_mod_type(NULL, opnum))
+ argop->op_private |= OPpCOREARGS_SCALARMOD;
}
return o;
default:
- o = convert(opnum,0,argop);
+ o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
if (is_handle_constructor(o, 2))
argop->op_private |= OPpCOREARGS_DEREF2;
- if (scalar_mod_type(NULL, opnum))
- argop->op_private |= OPpCOREARGS_SCALARMOD;
if (opnum == OP_SUBSTR) {
o->op_private |= OPpMAYBE_LVSUB;
return o;
name);
}
+/*
+=head1 Hook manipulation
+
+These functions provide convenient and thread-safe means of manipulating
+hook variables.
+
+=cut
+*/
+
+/*
+=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
+
+Puts a C function into the chain of check functions for a specified op
+type. This is the preferred way to manipulate the L</PL_check> array.
+I<opcode> specifies which type of op is to be affected. I<new_checker>
+is a pointer to the C function that is to be added to that opcode's
+check chain, and I<old_checker_p> points to the storage location where a
+pointer to the next function in the chain will be stored. The value of
+I<new_pointer> is written into the L</PL_check> array, while the value
+previously stored there is written to I<*old_checker_p>.
+
+L</PL_check> is global to an entire process, and a module wishing to
+hook op checking may find itself invoked more than once per process,
+typically in different threads. To handle that situation, this function
+is idempotent. The location I<*old_checker_p> must initially (once
+per process) contain a null pointer. A C variable of static duration
+(declared at file scope, typically also marked C<static> to give
+it internal linkage) will be implicitly initialised appropriately,
+if it does not have an explicit initialiser. This function will only
+actually modify the check chain if it finds I<*old_checker_p> to be null.
+This function is also thread safe on the small scale. It uses appropriate
+locking to avoid race conditions in accessing L</PL_check>.
+
+When this function is called, the function referenced by I<new_checker>
+must be ready to be called, except for I<*old_checker_p> being unfilled.
+In a threading situation, I<new_checker> may be called immediately,
+even before this function has returned. I<*old_checker_p> will always
+be appropriately set before I<new_checker> is called. If I<new_checker>
+decides not to do anything special with an op that it is given (which
+is the usual case for most uses of op check hooking), it must chain the
+check function referenced by I<*old_checker_p>.
+
+If you want to influence compilation of calls to a specific subroutine,
+then use L</cv_set_call_checker> rather than hooking checking of all
+C<entersub> ops.
+
+=cut
+*/
+
+void
+Perl_wrap_op_checker(pTHX_ Optype opcode,
+ Perl_check_t new_checker, Perl_check_t *old_checker_p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
+ if (*old_checker_p) return;
+ OP_CHECK_MUTEX_LOCK;
+ if (!*old_checker_p) {
+ *old_checker_p = PL_check[opcode];
+ PL_check[opcode] = new_checker;
+ }
+ OP_CHECK_MUTEX_UNLOCK;
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/