#define PERL_IN_OP_C
#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
+
+/* 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)
+{
+#ifdef PERL_DEBUG_READONLY_OPS
+ 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
+ OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+#endif
+ 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;
- /*
- * 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) {
+ 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 need to allocate chunk by chunk so that we can control the VM
- mapping */
- PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0);
-
- DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
- (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
- PL_OpPtr));
- if(PL_OpPtr == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
-#else
+void
+Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
+{
+ PERL_ARGS_ASSERT_SLAB_TO_RO;
- PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,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;
+ 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);
+ }
+}
-#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
+STATIC void
+S_Slab_to_rw(pTHX_ void *op)
+{
+ OP * const o = (OP *)op;
+ OPSLAB *slab;
+ OPSLAB *slab2;
+
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
+
+ if (!o->op_slabbed) return;
+
+ slab = OpSLAB(o);
+ 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);
+ }
}
- 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);
+ slab->opslab_readonly = 0;
}
-#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;
+#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) {
+ 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)
{
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;
- }
- }
-}
#endif
/*
* In the following definition, the ", (OP*)0" is just to make the compiler
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_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, OP_DESC(kid)), flags);
+}
- yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)));
+STATIC void
+S_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
/* 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;
case G_ARRAY: return list(o);
case G_VOID: return scalarvoid(o);
default:
- Perl_croak(aTHX_ "panic: op_contextualize bad context");
+ Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
+ (long) context);
return o;
}
}
/* establish postfix order */
first = cUNOPo->op_first;
if (first) {
- register OP *kid;
+ OP *kid;
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
{
dVAR;
OP *kid;
+ SV *useless_sv = NULL;
const char* useless = NULL;
- U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
case OP_GGRGID:
case OP_GETLOGIN:
case OP_PROTOTYPE:
+ case OP_RUNCV:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
/* Otherwise it's "Useless use of grep iterator" */
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
- useless_is_utf8 = SvUTF8(msv);
- }
- else
- useless = "a constant (undef)";
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
useless = NULL;
+ else {
+ 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);
+ }
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
}
+ else
+ useless = "a constant (undef)";
}
}
op_null(o); /* don't execute or even remember it */
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;
}
LEAVE;
}
-void
+STATIC void
S_finalize_op(pTHX_ OP* o)
{
PERL_ARGS_ASSERT_FINALIZE_OP;
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;
assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+ if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
+
switch (o->op_type) {
case OP_UNDEF:
- localize = 0;
PL_modcount++;
return o;
case OP_STUB:
|(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
- /* Backward compatibility mode: */
+ /* Potential lvalue context: */
o->op_private |= OPpENTERSUB_INARGS;
break;
}
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)
while (kid->op_sibling)
kid = kid->op_sibling;
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
- /* Indirect call */
- if (kid->op_type == OP_METHOD_NAMED
- || kid->op_type == OP_METHOD)
- {
- UNOP *newop;
-
- NewOp(1101, newop, 1, UNOP);
- newop->op_type = OP_RV2CV;
- newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
- newop->op_first = NULL;
- newop->op_next = (OP*)newop;
- kid->op_sibling = (OP*)newop;
- newop->op_private |= OPpLVAL_INTRO;
- newop->op_private &= ~1;
- break;
- }
-
- if (kid->op_type != OP_RV2CV)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%"UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid->op_private |= OPpLVAL_INTRO;
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;
"entry via type/targ %ld:%"UVuf,
(long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
- /* Restore RV2CV to check lvalueness */
- restore_2cv:
- if (kid->op_next && kid->op_next != kid) { /* Happens? */
- okid->op_next = kid->op_next;
- kid->op_next = okid;
- }
- else
- okid->op_next = NULL;
- okid->op_type = OP_RV2CV;
- okid->op_targ = 0;
- okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
- okid->op_private |= OPpLVAL_INTRO;
- okid->op_private &= ~1;
break;
}
cv = GvCV(kGVOP_gv);
if (!cv)
- goto restore_2cv;
+ break;
if (CvLVALUE(cv))
break;
}
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:
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 ||
|| rtype == OP_TRANSR
)
? (int)rtype : OP_MATCH];
- const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
+ GV *gv;
+ SV * const name =
+ (ltype == OP_RV2AV || ltype == OP_RV2HV)
+ ? cUNOPx(left)->op_first->op_type == OP_GV
+ && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
+ ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
+ : NULL
+ : varname(
+ (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
+ );
+ if (name)
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Applying %s to %"SVf" will act on scalar(%"SVf")",
+ desc, name, name);
+ else {
+ const char * const sample = (isary
? "@array" : "%hash");
- Perl_warner(aTHX_ packWARN(WARN_MISC),
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
+ }
}
if (rtype == OP_CONST &&
}
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)
{
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) {
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;
case OP_SCMP:
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (PL_hints & HINT_LOCALE)
+ 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);
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
else
dVAR;
OP *o;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
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));
dVAR;
UNOP *unop;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
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++) {
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
- if (PL_hints & HINT_LOCALE) {
+ if (IN_LOCALE_COMPILETIME) {
set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
- else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
+ else if ((! (PL_hints & HINT_BYTES))
+ /* Both UNI_8_BIT and locale :not_characters imply Unicode */
+ && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
+ {
set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
* 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);
+ /* 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;
+
+ LINKLIST(expr);
+
+ /* fix up DO blocks; treat each one as a separate little sub */
+
+ 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);
+ }
+ }
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
+ assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
- if (expr->op_type == OP_CONST) {
- SV *pat = ((SVOP*)expr)->op_sv;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ if (is_compiletime) {
+ U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ regexp_engine const *eng = current_re_engine();
if (o->op_flags & OPf_SPECIAL)
- pm_flags |= RXf_SPLIT;
-
- if (DO_UTF8(pat)) {
- assert (SvUTF8(pat));
- } else if (SvUTF8(pat)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if we're
- trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on, as
- the compiler now honours the SvUTF8 flag on pat. */
- STRLEN len;
- const char *const p = SvPV(pat, len);
- pat = newSVpvn_flags(p, len, SVs_TEMP);
- }
-
- PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+ rx_flags |= RXf_SPLIT;
+
+ 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);
+ ((struct regexp *)SvANY(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;
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);
NewOp(1101, pvop, 1, PVOP);
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)
PERL_ARGS_ASSERT_PACKAGE;
- save_hptr(&PL_curstash);
+ SAVEGENERICSV(PL_curstash);
save_item(PL_curstname);
- PL_curstash = gv_stashsv(sv, GV_ADD);
+ PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
sv_setsv(PL_curstname, sv);
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) {
- /* If we request a version >= 5.9.5, load feature.pm with the
+ /* Enable the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
+ S_enable_feature_bundle(aTHX_ use_version);
- if (vcmp(use_version,
- sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(use_version);
- *SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
- }
/* 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) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints |= HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints |= HINT_STRICT_SUBS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
+ PL_hints |= HINT_STRICT_VARS;
+ }
+ /* otherwise they are off */
+ else {
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints &= ~HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints &= ~HINT_STRICT_SUBS;
+ 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
}
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified, provides version semantics
+(or 0 for no flags). ver, if specified and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
Otherwise at least a single NULL pointer to designate the default
import list is required.
+The reference count for each specified C<SV*> parameter is decremented.
+
=cut */
void
}
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 {
|| 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;
}
/* This is a default {} block */
enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
+ o ->op_flags |= OPf_SPECIAL;
o->op_next = (OP *) enterop;
}
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 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 *
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
+ return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
+}
+
+CV *
+Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, U32 flags)
+{
dVAR;
GV *gv;
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;
- const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
+ STRLEN namlen = 0;
+ const bool o_is_gv = flags & 1;
+ const char * const name =
+ o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
- bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
+ 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);
else
ps = NULL;
- if (name) {
+ if (o_is_gv) {
+ gv = (GV*)o;
+ o = NULL;
+ has_name = TRUE;
+ } else if (name) {
gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
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);
&& block->op_type != OP_NULL
#endif
) {
- if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
- {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
- : "Subroutine %"SVf" redefined",
- SVfARG(cSVOPo->op_sv));
- CopLINE_set(PL_curcop, oldline);
- }
+ report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
#ifdef PERL_MAD
if (!PL_minus_c) /* keep old one around for madskills */
#endif
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;
}
else {
GvCV_set(gv, NULL);
- cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
- }
- mro_method_changed_in( /* sub Foo::Bar () { 123 } */
- (CvGV(cv) && GvSTASH(CvGV(cv)))
- ? GvSTASH(CvGV(cv))
- : CvSTASH(cv)
- ? CvSTASH(cv)
- : PL_curstash
- );
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
+ }
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));
}
}
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ /* sub Foo::bar { (shift)+1 } */
+ mro_method_changed_in(GvSTASH(gv));
}
}
if (!CvGV(cv)) {
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
- attrs:
- if (attrs) {
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
- }
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
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 done;
+ 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
#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));
CvCONST_on(cv);
}
- if (has_name) {
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
+
+ if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",
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;
}
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
+ SAVEVPTR(PL_curcop);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
- PL_curcop = &PL_compiling;
CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Too late to run CHECK block");
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Too late to run INIT block");
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
CV *
Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
{
- return newCONSTSUB_flags(stash, name, 0, sv);
+ return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
}
/*
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
*/
CV *
-Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
+Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
+ U32 flags, SV *sv)
{
dVAR;
CV* cv;
* an op shared between threads. Use a non-shared COP for our
* dirty work */
SAVEVPTR(PL_curcop);
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
PL_curcop = &PL_compiling;
}
SAVECOPLINE(PL_curcop);
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash) {
- SAVESPTR(PL_curstash);
- SAVECOPSTASH(PL_curcop);
- PL_curstash = stash;
- CopSTASH_set(PL_curcop,stash);
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
}
/* file becomes the CvFILE. For an XS, it's usually static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
- XS_DYNAMIC_FILENAME | flags);
+ cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+ &sv, XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
-#ifdef USE_ITHREADS
- if (stash)
- CopSTASH_free(PL_curcop);
-#endif
LEAVE;
return cv;
const char *const filename, const char *const proto,
U32 flags)
{
+ PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
+ );
+}
+
+CV *
+Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
+ XSUBADDR_t subaddr, const char *const filename,
+ const char *const proto, SV **const_svp,
+ U32 flags)
+{
CV *cv;
- PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
{
- GV * const gv = gv_fetchpv(name ? name :
+ 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);
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- if (ckWARN(WARN_REDEFINE)) {
- GV * const gvcv = CvGV(cv);
- if (gvcv) {
- HV * const stash = GvSTASH(gvcv);
- if (stash) {
- const char *redefined_name = HvNAME_get(stash);
- if ( redefined_name &&
- strEQ(redefined_name,"autouse") ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"
- ,name);
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
+ /* 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;
if (name) {
GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
if (!name)
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);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
} else {
+ /* diag_listed_as: Format %s redefined */
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format STDOUT redefined");
}
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');
return o;
}
+PERL_STATIC_INLINE bool
+is_dollar_bracket(pTHX_ const OP * const o)
+{
+ const OP *kid;
+ return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
+ && (kid = cUNOPx(o)->op_first)
+ && kid->op_type == OP_GV
+ && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
+}
+
+OP *
+Perl_ck_cmp(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_CMP;
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = cUNOPo->op_first;
+ if (kid && (
+ (
+ is_dollar_bracket(aTHX_ kid)
+ && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
+ )
+ || ( kid->op_type == OP_CONST
+ && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
+ ))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "$[ used in %s (did you mean $] ?)", OP_DESC(o));
+ }
+ return o;
+}
+
OP *
Perl_ck_concat(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_EOF;
if (o->op_flags & OPf_KIDS) {
+ OP *kid;
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
#endif
o = newop;
}
- return ck_fun(o);
+ o = ck_fun(o);
+ kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV)
+ kid->op_private |= OPpALLOW_FAKE;
}
return o;
}
}
}
else {
+ const U8 priv = o->op_private;
#ifdef PERL_MAD
OP* const oldo = o;
#else
op_free(o);
#endif
- o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
- if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
+ if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
+ if ((PL_hints & HINT_LOCALIZE_HH) != 0
+ && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
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)
+ && 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
&& kidtype != OP_STAT && kidtype != OP_LSTAT) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
+ if (kidtype == OP_FTTTY && (
+ !(kid->op_private & OPpFT_STACKED)
+ || kid->op_private & OPpFT_AFTER_t
+ ))
+ o->op_private |= OPpFT_AFTER_t;
}
}
else {
{
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;
const char *name = NULL;
STRLEN len = 0;
U32 name_utf8 = 0;
+ bool want_dollar = TRUE;
flags = 0;
/* Set a flag to tell rv2gv to vivify
if (!name) {
name = "__ANONIO__";
len = 10;
+ want_dollar = FALSE;
}
op_lvalue(kid, type);
}
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
SvUPGRADE(namesv, SVt_PV);
- if (*name != '$')
+ if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
if ( name_utf8 ) SvUTF8_on(namesv);
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;
}
{
dVAR;
GV *gv;
+ const bool core = o->op_flags & OPf_SPECIAL;
PERL_ARGS_ASSERT_CK_GLOB;
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
- if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
+ if (core) gv = NULL;
+ 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))) {
- GV *glob_gv;
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs("File::Glob"), NULL, NULL, NULL);
- if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV_set(gv, GvCV(glob_gv));
- SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
- GvIMPORTED_CV_on(gv);
- }
- LEAVE;
- }
-#endif /* PERL_EXTERNAL_GLOB */
-
- assert(!(o->op_flags & OPf_SPECIAL));
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
+ sv_setiv(GvSVn(gv),PL_glob_index++);
+#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
scalarkids(o);
return o;
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;
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_grep");
+ 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);
if ((o->op_flags & OPf_KIDS)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
- /* This is needed for
- if (defined %stash::)
- to work. Do not break Tk.
- */
- break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
{
PERL_ARGS_ASSERT_CK_READLINE;
- if (!(o->op_flags & OPf_KIDS)) {
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ else {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
#ifdef PERL_MAD
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;
if (!kid)
op_append_elem(o->op_type, o, newDEFSVOP());
+ if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
return listkids(o);
}
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- OP * const kid = cUNOPo->op_first;
- OP * newop;
-
- cUNOPo->op_first = 0;
+ OP *kid, *newop;
+ if (o->op_flags & OPf_KIDS) {
+ kid = cUNOPo->op_first;
+ cUNOPo->op_first = NULL;
+ }
+ else {
+ kid = newDEFSVOP();
+ }
#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;
}
- else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
- op_null(firstkid);
firstkid = firstkid->op_sibling;
}
/* 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;
kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split");
+ Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
if (kid)
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, OPf_SPECIAL), 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);
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);
else proto = SvPV(protosv, proto_len);
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;
}
for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
aop = aop->op_sibling;
- continue;
}
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]) {
}
else {
OP *prev, *cvop;
- U32 paren;
+ U32 flags;
#ifdef PERL_MAD
bool seenarg = FALSE;
#endif
#endif
;
prev->op_sibling = NULL;
- paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
op_free(cvop);
if (aop == cvop) aop = NULL;
op_free(entersubop);
+ if (opnum == OP_ENTEREVAL
+ && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+ flags |= OPpEVAL_BYTES <<8;
+
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
case OA_FILESTATOP:
- return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+ return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
#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 newOP(opnum,0);
+ return opnum == OP_RUNCV
+ ? newPVOP(OP_RUNCV,0,NULL)
+ : newOP(opnum,0);
default:
return convert(opnum,0,aop);
}
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
+ callmg->mg_flags |= MGf_COPY;
}
}
}
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;
}
OP *
+Perl_ck_tell(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_TELL;
+ o = ck_fun(o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ return o;
+}
+
+OP *
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
return o->op_type == ref_type ? o : ck_fun(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;
+OP *
+Perl_ck_length(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_LENGTH;
- PERL_ARGS_ASSERT_OPT_SCALARHV;
+ o = ck_fun(o);
- 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;
-}
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
+
+ if (kid) {
+ SV *name = NULL;
+ const bool hash = kid->op_type == OP_PADHV
+ || kid->op_type == OP_RV2HV;
+ switch (kid->op_type) {
+ case OP_PADHV:
+ case OP_PADAV:
+ name = varname(
+ (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
+ NULL, 0, 1
+ );
+ break;
+ case OP_RV2HV:
+ case OP_RV2AV:
+ if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
+ {
+ GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
+ if (!gv) break;
+ name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
+ }
+ break;
+ default:
+ return o;
+ }
+ if (name)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
+ ")\"?)",
+ name, hash ? "keys " : "", name
+ );
+ else if (hash)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
+ else
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on @array (did you mean \"scalar(@array)\"?)");
+ }
+ }
+
+ return o;
+}
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
return;
assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
- oright = cUNOPx(modop)->op_first->op_sibling;
+ if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
if (modop->op_flags & OPf_STACKED) {
/* skip sort subroutine/block */
if (oright->op_type != OP_RV2AV
|| !cUNOPx(oright)->op_first
|| cUNOPx(oright)->op_first->op_type != OP_GV
+ || cUNOPx(oleft )->op_first->op_type != OP_GV
|| cGVOPx_gv(cUNOPx(oleft)->op_first) !=
cGVOPx_gv(cUNOPx(oright)->op_first)
)
#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;
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)
- )
+#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)
+
+ 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 |= OPpMAYBE_TRUEBOOL;
+#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;
}
break;
+ case OP_RUNCV:
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ SV *sv;
+ if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
+ else {
+ sv = newRV((SV *)PL_compcv);
+ sv_rvweaken(sv);
+ SvREADONLY_on(sv);
+ }
+ o->op_type = OP_CONST;
+ o->op_ppaddr = PL_ppaddr[OP_CONST];
+ o->op_flags |= OPf_SPECIAL;
+ cSVOPo->op_sv = sv;
+ }
+ break;
+
+ case OP_SASSIGN:
+ if (OP_GIMME(o,0) == G_VOID) {
+ OP *right = cBINOP->op_first;
+ if (right) {
+ OP *left = right->op_sibling;
+ if (left->op_type == OP_SUBSTR
+ && (left->op_private & 7) < 4) {
+ op_null(o);
+ cBINOP->op_first = left;
+ right->op_sibling =
+ cBINOPx(left)->op_first->op_sibling;
+ cBINOPx(left)->op_first->op_sibling = right;
+ left->op_private |= OPpSUBSTR_REPL_FIRST;
+ left->op_flags =
+ (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ }
+ }
+ }
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
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__:
retsetpvs("", 0);
+ case KEY_evalbytes:
+ name = "entereval"; break;
case KEY_readpipe:
name = "backtick";
}
}
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++] = ']';
}
return op_append_elem(
OP_LINESEQ, argop,
newOP(opnum,
- opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
+ opnum == OP_WANTARRAY || opnum == OP_RUNCV
+ ? OPpOFFBYONE << 8 : 0)
);
case OA_BASEOP_OR_UNOP:
- o = newUNOP(opnum,0,argop);
+ if (opnum == OP_ENTEREVAL) {
+ o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
+ if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
+ }
+ else o = newUNOP(opnum,0,argop);
if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
else {
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;
}
}
+void
+Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
+ SV * const *new_const_svp)
+{
+ const char *hvname;
+ bool is_const = !!CvCONST(old_cv);
+ SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
+
+ PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
+
+ if (is_const && new_const_svp && old_const_sv == *new_const_svp)
+ return;
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ if (
+ (ckWARN(WARN_REDEFINE)
+ && !(
+ CvGV(old_cv) && GvSTASH(CvGV(old_cv))
+ && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
+ && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
+ strEQ(hvname, "autouse"))
+ )
+ )
+ || (is_const
+ && ckWARN_d(WARN_REDEFINE)
+ && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
+ )
+ )
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ is_const
+ ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ 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:
*/
https://perl5.git.perl.org / perl5.git / blobdiff