4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* See the explanatory comments above struct opslab in op.h. */
114 #ifdef PERL_DEBUG_READONLY_OPS
115 # define PERL_SLAB_SIZE 128
116 # define PERL_MAX_SLAB_SIZE 4096
117 # include <sys/mman.h>
120 #ifndef PERL_SLAB_SIZE
121 # define PERL_SLAB_SIZE 64
123 #ifndef PERL_MAX_SLAB_SIZE
124 # define PERL_MAX_SLAB_SIZE 2048
127 /* rounds up to nearest pointer */
128 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
132 S_new_slab(pTHX_ size_t sz)
134 #ifdef PERL_DEBUG_READONLY_OPS
135 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136 PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) sz, slab));
140 if (slab == MAP_FAILED) {
141 perror("mmap failed");
144 slab->opslab_size = (U16)sz;
146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
152 /* requires double parens and aTHX_ */
153 #define DEBUG_S_warn(args) \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
159 Perl_Slab_Alloc(pTHX_ size_t sz)
168 /* We only allocate ops from the slab during subroutine compilation.
169 We find the slab via PL_compcv, hence that must be non-NULL. It could
170 also be pointing to a subroutine which is now fully set up (CvROOT()
171 pointing to the top of the optree for that sub), or a subroutine
172 which isn't using the slab allocator. If our sanity checks aren't met,
173 don't use a slab, but allocate the OP directly from the heap. */
174 if (!PL_compcv || CvROOT(PL_compcv)
175 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
176 return PerlMemShared_calloc(1, sz);
178 /* While the subroutine is under construction, the slabs are accessed via
179 CvSTART(), to avoid needing to expand PVCV by one pointer for something
180 unneeded at runtime. Once a subroutine is constructed, the slabs are
181 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
182 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
184 if (!CvSTART(PL_compcv)) {
186 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
187 CvSLABBED_on(PL_compcv);
188 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
190 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
192 opsz = SIZE_TO_PSIZE(sz);
193 sz = opsz + OPSLOT_HEADER_P;
195 /* The slabs maintain a free list of OPs. In particular, constant folding
196 will free up OPs, so it makes sense to re-use them where possible. A
197 freed up slot is used in preference to a new allocation. */
198 if (slab->opslab_freed) {
199 OP **too = &slab->opslab_freed;
201 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
202 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
203 DEBUG_S_warn((aTHX_ "Alas! too small"));
204 o = *(too = &o->op_next);
205 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
209 Zero(o, opsz, I32 *);
215 #define INIT_OPSLOT \
216 slot->opslot_slab = slab; \
217 slot->opslot_next = slab2->opslab_first; \
218 slab2->opslab_first = slot; \
219 o = &slot->opslot_op; \
222 /* The partially-filled slab is next in the chain. */
223 slab2 = slab->opslab_next ? slab->opslab_next : slab;
224 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
225 /* Remaining space is too small. */
227 /* If we can fit a BASEOP, add it to the free chain, so as not
229 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
230 slot = &slab2->opslab_slots;
232 o->op_type = OP_FREED;
233 o->op_next = slab->opslab_freed;
234 slab->opslab_freed = o;
237 /* Create a new slab. Make this one twice as big. */
238 slot = slab2->opslab_first;
239 while (slot->opslot_next) slot = slot->opslot_next;
240 slab2 = S_new_slab(aTHX_
241 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
243 : (DIFF(slab2, slot)+1)*2);
244 slab2->opslab_next = slab->opslab_next;
245 slab->opslab_next = slab2;
247 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
249 /* Create a new op slot */
250 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
251 assert(slot >= &slab2->opslab_slots);
252 if (DIFF(&slab2->opslab_slots, slot)
253 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
254 slot = &slab2->opslab_slots;
256 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
262 #ifdef PERL_DEBUG_READONLY_OPS
264 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
266 PERL_ARGS_ASSERT_SLAB_TO_RO;
268 if (slab->opslab_readonly) return;
269 slab->opslab_readonly = 1;
270 for (; slab; slab = slab->opslab_next) {
271 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
272 (unsigned long) slab->opslab_size, slab));*/
273 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
274 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
275 (unsigned long)slab->opslab_size, errno);
280 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
284 PERL_ARGS_ASSERT_SLAB_TO_RW;
286 if (!slab->opslab_readonly) return;
288 for (; slab2; slab2 = slab2->opslab_next) {
289 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
290 (unsigned long) size, slab2));*/
291 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
292 PROT_READ|PROT_WRITE)) {
293 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
294 (unsigned long)slab2->opslab_size, errno);
297 slab->opslab_readonly = 0;
301 # define Slab_to_rw(op) NOOP
304 /* This cannot possibly be right, but it was copied from the old slab
305 allocator, to which it was originally added, without explanation, in
308 # define PerlMemShared PerlMem
312 Perl_Slab_Free(pTHX_ void *op)
315 OP * const o = (OP *)op;
318 PERL_ARGS_ASSERT_SLAB_FREE;
320 if (!o->op_slabbed) {
322 PerlMemShared_free(op);
327 /* If this op is already freed, our refcount will get screwy. */
328 assert(o->op_type != OP_FREED);
329 o->op_type = OP_FREED;
330 o->op_next = slab->opslab_freed;
331 slab->opslab_freed = o;
332 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
333 OpslabREFCNT_dec_padok(slab);
337 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
340 const bool havepad = !!PL_comppad;
341 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
344 PAD_SAVE_SETNULLPAD();
351 Perl_opslab_free(pTHX_ OPSLAB *slab)
355 PERL_ARGS_ASSERT_OPSLAB_FREE;
356 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
357 assert(slab->opslab_refcnt == 1);
358 for (; slab; slab = slab2) {
359 slab2 = slab->opslab_next;
361 slab->opslab_refcnt = ~(size_t)0;
363 #ifdef PERL_DEBUG_READONLY_OPS
364 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
366 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
367 perror("munmap failed");
371 PerlMemShared_free(slab);
377 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
382 size_t savestack_count = 0;
384 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
387 for (slot = slab2->opslab_first;
389 slot = slot->opslot_next) {
390 if (slot->opslot_op.op_type != OP_FREED
391 && !(slot->opslot_op.op_savefree
397 assert(slot->opslot_op.op_slabbed);
398 op_free(&slot->opslot_op);
399 if (slab->opslab_refcnt == 1) goto free;
402 } while ((slab2 = slab2->opslab_next));
403 /* > 1 because the CV still holds a reference count. */
404 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
406 assert(savestack_count == slab->opslab_refcnt-1);
408 /* Remove the CV’s reference count. */
409 slab->opslab_refcnt--;
416 #ifdef PERL_DEBUG_READONLY_OPS
418 Perl_op_refcnt_inc(pTHX_ OP *o)
421 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
422 if (slab && slab->opslab_readonly) {
435 Perl_op_refcnt_dec(pTHX_ OP *o)
438 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
440 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
442 if (slab && slab->opslab_readonly) {
444 result = --o->op_targ;
447 result = --o->op_targ;
453 * In the following definition, the ", (OP*)0" is just to make the compiler
454 * think the expression is of the right type: croak actually does a Siglongjmp.
456 #define CHECKOP(type,o) \
457 ((PL_op_mask && PL_op_mask[type]) \
458 ? ( op_free((OP*)o), \
459 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
461 : PL_check[type](aTHX_ (OP*)o))
463 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
465 #define CHANGE_TYPE(o,type) \
467 o->op_type = (OPCODE)type; \
468 o->op_ppaddr = PL_ppaddr[type]; \
472 S_gv_ename(pTHX_ GV *gv)
474 SV* const tmpsv = sv_newmortal();
476 PERL_ARGS_ASSERT_GV_ENAME;
478 gv_efullname3(tmpsv, gv, NULL);
483 S_no_fh_allowed(pTHX_ OP *o)
485 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
487 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
493 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
495 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
496 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
497 SvUTF8(namesv) | flags);
502 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
504 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
505 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
510 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
512 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
514 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
519 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
521 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
523 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
524 SvUTF8(namesv) | flags);
529 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
531 PERL_ARGS_ASSERT_BAD_TYPE_PV;
533 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
534 (int)n, name, t, OP_DESC(kid)), flags);
538 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
540 SV * const namesv = gv_ename(gv);
541 PERL_ARGS_ASSERT_BAD_TYPE_GV;
543 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
544 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
548 S_no_bareword_allowed(pTHX_ OP *o)
550 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
553 return; /* various ok barewords are hidden in extra OP_NULL */
554 qerror(Perl_mess(aTHX_
555 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
557 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
560 /* "register" allocation */
563 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
567 const bool is_our = (PL_parser->in_my == KEY_our);
569 PERL_ARGS_ASSERT_ALLOCMY;
571 if (flags & ~SVf_UTF8)
572 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
575 /* Until we're using the length for real, cross check that we're being
577 assert(strlen(name) == len);
579 /* complain about "my $<special_var>" etc etc */
583 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
584 (name[1] == '_' && (*name == '$' || len > 2))))
586 /* name[2] is true if strlen(name) > 2 */
587 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
588 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
589 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
590 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
591 PL_parser->in_my == KEY_state ? "state" : "my"));
593 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
594 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
597 else if (len == 2 && name[1] == '_' && !is_our)
598 /* diag_listed_as: Use of my $_ is experimental */
599 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
600 "Use of %s $_ is experimental",
601 PL_parser->in_my == KEY_state
605 /* allocate a spare slot and store the name in that slot */
607 off = pad_add_name_pvn(name, len,
608 (is_our ? padadd_OUR :
609 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
610 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
611 PL_parser->in_my_stash,
613 /* $_ is always in main::, even with our */
614 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
618 /* anon sub prototypes contains state vars should always be cloned,
619 * otherwise the state var would be shared between anon subs */
621 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
622 CvCLONE_on(PL_compcv);
628 =for apidoc alloccopstash
630 Available only under threaded builds, this function allocates an entry in
631 C<PL_stashpad> for the stash passed to it.
638 Perl_alloccopstash(pTHX_ HV *hv)
640 PADOFFSET off = 0, o = 1;
641 bool found_slot = FALSE;
643 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
645 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
647 for (; o < PL_stashpadmax; ++o) {
648 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
649 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
650 found_slot = TRUE, off = o;
653 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
654 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
655 off = PL_stashpadmax;
656 PL_stashpadmax += 10;
659 PL_stashpad[PL_stashpadix = off] = hv;
664 /* free the body of an op without examining its contents.
665 * Always use this rather than FreeOp directly */
668 S_op_destroy(pTHX_ OP *o)
676 =for apidoc Am|void|op_free|OP *o
678 Free an op. Only use this when an op is no longer linked to from any
685 Perl_op_free(pTHX_ OP *o)
690 /* Though ops may be freed twice, freeing the op after its slab is a
692 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
693 /* During the forced freeing of ops after compilation failure, kidops
694 may be freed before their parents. */
695 if (!o || o->op_type == OP_FREED)
699 if (o->op_private & OPpREFCOUNTED) {
710 refcnt = OpREFCNT_dec(o);
713 /* Need to find and remove any pattern match ops from the list
714 we maintain for reset(). */
715 find_and_forget_pmops(o);
725 /* Call the op_free hook if it has been set. Do it now so that it's called
726 * at the right time for refcounted ops, but still before all of the kids
730 if (o->op_flags & OPf_KIDS) {
732 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
733 nextkid = kid->op_sibling; /* Get before next freeing kid */
738 type = (OPCODE)o->op_targ;
741 Slab_to_rw(OpSLAB(o));
743 /* COP* is not cleared by op_clear() so that we may track line
744 * numbers etc even after null() */
745 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
751 #ifdef DEBUG_LEAKING_SCALARS
758 Perl_op_clear(pTHX_ OP *o)
763 PERL_ARGS_ASSERT_OP_CLEAR;
766 mad_free(o->op_madprop);
771 switch (o->op_type) {
772 case OP_NULL: /* Was holding old type, if any. */
773 if (PL_madskills && o->op_targ != OP_NULL) {
774 o->op_type = (Optype)o->op_targ;
779 case OP_ENTEREVAL: /* Was holding hints. */
783 if (!(o->op_flags & OPf_REF)
784 || (PL_check[o->op_type] != Perl_ck_ftst))
791 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
796 /* It's possible during global destruction that the GV is freed
797 before the optree. Whilst the SvREFCNT_inc is happy to bump from
798 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
799 will trigger an assertion failure, because the entry to sv_clear
800 checks that the scalar is not already freed. A check of for
801 !SvIS_FREED(gv) turns out to be invalid, because during global
802 destruction the reference count can be forced down to zero
803 (with SVf_BREAK set). In which case raising to 1 and then
804 dropping to 0 triggers cleanup before it should happen. I
805 *think* that this might actually be a general, systematic,
806 weakness of the whole idea of SVf_BREAK, in that code *is*
807 allowed to raise and lower references during global destruction,
808 so any *valid* code that happens to do this during global
809 destruction might well trigger premature cleanup. */
810 bool still_valid = gv && SvREFCNT(gv);
813 SvREFCNT_inc_simple_void(gv);
815 if (cPADOPo->op_padix > 0) {
816 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
817 * may still exist on the pad */
818 pad_swipe(cPADOPo->op_padix, TRUE);
819 cPADOPo->op_padix = 0;
822 SvREFCNT_dec(cSVOPo->op_sv);
823 cSVOPo->op_sv = NULL;
826 int try_downgrade = SvREFCNT(gv) == 2;
829 gv_try_downgrade(gv);
833 case OP_METHOD_NAMED:
836 SvREFCNT_dec(cSVOPo->op_sv);
837 cSVOPo->op_sv = NULL;
840 Even if op_clear does a pad_free for the target of the op,
841 pad_free doesn't actually remove the sv that exists in the pad;
842 instead it lives on. This results in that it could be reused as
843 a target later on when the pad was reallocated.
846 pad_swipe(o->op_targ,1);
856 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
861 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
862 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
864 if (cPADOPo->op_padix > 0) {
865 pad_swipe(cPADOPo->op_padix, TRUE);
866 cPADOPo->op_padix = 0;
869 SvREFCNT_dec(cSVOPo->op_sv);
870 cSVOPo->op_sv = NULL;
874 PerlMemShared_free(cPVOPo->op_pv);
875 cPVOPo->op_pv = NULL;
879 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
883 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
884 /* No GvIN_PAD_off here, because other references may still
885 * exist on the pad */
886 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
889 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
895 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
896 op_free(cPMOPo->op_code_list);
897 cPMOPo->op_code_list = NULL;
899 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
900 /* we use the same protection as the "SAFE" version of the PM_ macros
901 * here since sv_clean_all might release some PMOPs
902 * after PL_regex_padav has been cleared
903 * and the clearing of PL_regex_padav needs to
904 * happen before sv_clean_all
907 if(PL_regex_pad) { /* We could be in destruction */
908 const IV offset = (cPMOPo)->op_pmoffset;
909 ReREFCNT_dec(PM_GETRE(cPMOPo));
910 PL_regex_pad[offset] = &PL_sv_undef;
911 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
915 ReREFCNT_dec(PM_GETRE(cPMOPo));
916 PM_SETRE(cPMOPo, NULL);
922 if (o->op_targ > 0) {
923 pad_free(o->op_targ);
929 S_cop_free(pTHX_ COP* cop)
931 PERL_ARGS_ASSERT_COP_FREE;
934 if (! specialWARN(cop->cop_warnings))
935 PerlMemShared_free(cop->cop_warnings);
936 cophh_free(CopHINTHASH_get(cop));
937 if (PL_curcop == cop)
942 S_forget_pmop(pTHX_ PMOP *const o
945 HV * const pmstash = PmopSTASH(o);
947 PERL_ARGS_ASSERT_FORGET_PMOP;
949 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
950 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
952 PMOP **const array = (PMOP**) mg->mg_ptr;
953 U32 count = mg->mg_len / sizeof(PMOP**);
958 /* Found it. Move the entry at the end to overwrite it. */
959 array[i] = array[--count];
960 mg->mg_len = count * sizeof(PMOP**);
961 /* Could realloc smaller at this point always, but probably
962 not worth it. Probably worth free()ing if we're the
965 Safefree(mg->mg_ptr);
978 S_find_and_forget_pmops(pTHX_ OP *o)
980 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
982 if (o->op_flags & OPf_KIDS) {
983 OP *kid = cUNOPo->op_first;
985 switch (kid->op_type) {
990 forget_pmop((PMOP*)kid);
992 find_and_forget_pmops(kid);
993 kid = kid->op_sibling;
999 =for apidoc Am|void|op_null|OP *o
1001 Neutralizes an op when it is no longer needed, but is still linked to from
1008 Perl_op_null(pTHX_ OP *o)
1012 PERL_ARGS_ASSERT_OP_NULL;
1014 if (o->op_type == OP_NULL)
1018 o->op_targ = o->op_type;
1019 o->op_type = OP_NULL;
1020 o->op_ppaddr = PL_ppaddr[OP_NULL];
1024 Perl_op_refcnt_lock(pTHX)
1027 PERL_UNUSED_CONTEXT;
1032 Perl_op_refcnt_unlock(pTHX)
1035 PERL_UNUSED_CONTEXT;
1039 /* Contextualizers */
1042 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1044 Applies a syntactic context to an op tree representing an expression.
1045 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1046 or C<G_VOID> to specify the context to apply. The modified op tree
1053 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1055 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1057 case G_SCALAR: return scalar(o);
1058 case G_ARRAY: return list(o);
1059 case G_VOID: return scalarvoid(o);
1061 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1068 =head1 Optree Manipulation Functions
1070 =for apidoc Am|OP*|op_linklist|OP *o
1071 This function is the implementation of the L</LINKLIST> macro. It should
1072 not be called directly.
1078 Perl_op_linklist(pTHX_ OP *o)
1082 PERL_ARGS_ASSERT_OP_LINKLIST;
1087 /* establish postfix order */
1088 first = cUNOPo->op_first;
1091 o->op_next = LINKLIST(first);
1094 if (kid->op_sibling) {
1095 kid->op_next = LINKLIST(kid->op_sibling);
1096 kid = kid->op_sibling;
1110 S_scalarkids(pTHX_ OP *o)
1112 if (o && o->op_flags & OPf_KIDS) {
1114 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1121 S_scalarboolean(pTHX_ OP *o)
1125 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1127 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1128 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1129 if (ckWARN(WARN_SYNTAX)) {
1130 const line_t oldline = CopLINE(PL_curcop);
1132 if (PL_parser && PL_parser->copline != NOLINE) {
1133 /* This ensures that warnings are reported at the first line
1134 of the conditional, not the last. */
1135 CopLINE_set(PL_curcop, PL_parser->copline);
1137 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1138 CopLINE_set(PL_curcop, oldline);
1145 S_op_varname(pTHX_ const OP *o)
1148 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1149 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1151 const char funny = o->op_type == OP_PADAV
1152 || o->op_type == OP_RV2AV ? '@' : '%';
1153 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1155 if (cUNOPo->op_first->op_type != OP_GV
1156 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1158 return varname(gv, funny, 0, NULL, 0, 1);
1161 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1166 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1167 { /* or not so pretty :-) */
1168 if (o->op_type == OP_CONST) {
1170 if (SvPOK(*retsv)) {
1172 *retsv = sv_newmortal();
1173 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1174 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1176 else if (!SvOK(*retsv))
1179 else *retpv = "...";
1183 S_scalar_slice_warning(pTHX_ const OP *o)
1187 o->op_type == OP_HSLICE ? '{' : '[';
1189 o->op_type == OP_HSLICE ? '}' : ']';
1191 SV *keysv = NULL; /* just to silence compiler warnings */
1192 const char *key = NULL;
1194 if (!(o->op_private & OPpSLICEWARNING))
1196 if (PL_parser && PL_parser->error_count)
1197 /* This warning can be nonsensical when there is a syntax error. */
1200 kid = cLISTOPo->op_first;
1201 kid = kid->op_sibling; /* get past pushmark */
1202 /* weed out false positives: any ops that can return lists */
1203 switch (kid->op_type) {
1232 /* Don't warn if we have a nulled list either. */
1233 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1236 assert(kid->op_sibling);
1237 name = S_op_varname(aTHX_ kid->op_sibling);
1238 if (!name) /* XS module fiddling with the op tree */
1240 S_op_pretty(aTHX_ kid, &keysv, &key);
1241 assert(SvPOK(name));
1242 sv_chop(name,SvPVX(name)+1);
1244 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1245 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1246 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1248 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1249 lbrack, key, rbrack);
1251 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1252 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1253 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1255 SVfARG(name), lbrack, keysv, rbrack,
1256 SVfARG(name), lbrack, keysv, rbrack);
1260 Perl_scalar(pTHX_ OP *o)
1265 /* assumes no premature commitment */
1266 if (!o || (PL_parser && PL_parser->error_count)
1267 || (o->op_flags & OPf_WANT)
1268 || o->op_type == OP_RETURN)
1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1275 switch (o->op_type) {
1277 scalar(cBINOPo->op_first);
1282 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1292 if (o->op_flags & OPf_KIDS) {
1293 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1299 kid = cLISTOPo->op_first;
1301 kid = kid->op_sibling;
1304 OP *sib = kid->op_sibling;
1305 if (sib && kid->op_type != OP_LEAVEWHEN)
1311 PL_curcop = &PL_compiling;
1316 kid = cLISTOPo->op_first;
1319 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1324 /* Warn about scalar context */
1325 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1326 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1329 const char *key = NULL;
1331 /* This warning can be nonsensical when there is a syntax error. */
1332 if (PL_parser && PL_parser->error_count)
1335 if (!ckWARN(WARN_SYNTAX)) break;
1337 kid = cLISTOPo->op_first;
1338 kid = kid->op_sibling; /* get past pushmark */
1339 assert(kid->op_sibling);
1340 name = S_op_varname(aTHX_ kid->op_sibling);
1341 if (!name) /* XS module fiddling with the op tree */
1343 S_op_pretty(aTHX_ kid, &keysv, &key);
1344 assert(SvPOK(name));
1345 sv_chop(name,SvPVX(name)+1);
1347 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1348 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1349 "%%%"SVf"%c%s%c in scalar context better written "
1351 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1352 lbrack, key, rbrack);
1354 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1355 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1356 "%%%"SVf"%c%"SVf"%c in scalar context better "
1357 "written as $%"SVf"%c%"SVf"%c",
1358 SVfARG(name), lbrack, keysv, rbrack,
1359 SVfARG(name), lbrack, keysv, rbrack);
1366 Perl_scalarvoid(pTHX_ OP *o)
1370 SV *useless_sv = NULL;
1371 const char* useless = NULL;
1375 PERL_ARGS_ASSERT_SCALARVOID;
1377 /* trailing mad null ops don't count as "there" for void processing */
1379 o->op_type != OP_NULL &&
1381 o->op_sibling->op_type == OP_NULL)
1384 for (sib = o->op_sibling;
1385 sib && sib->op_type == OP_NULL;
1386 sib = sib->op_sibling) ;
1392 if (o->op_type == OP_NEXTSTATE
1393 || o->op_type == OP_DBSTATE
1394 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1395 || o->op_targ == OP_DBSTATE)))
1396 PL_curcop = (COP*)o; /* for warning below */
1398 /* assumes no premature commitment */
1399 want = o->op_flags & OPf_WANT;
1400 if ((want && want != OPf_WANT_SCALAR)
1401 || (PL_parser && PL_parser->error_count)
1402 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1407 if ((o->op_private & OPpTARGET_MY)
1408 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1410 return scalar(o); /* As if inside SASSIGN */
1413 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1415 switch (o->op_type) {
1417 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1421 if (o->op_flags & OPf_STACKED)
1425 if (o->op_private == 4)
1450 case OP_AELEMFAST_LEX:
1471 case OP_GETSOCKNAME:
1472 case OP_GETPEERNAME:
1477 case OP_GETPRIORITY:
1502 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1503 /* Otherwise it's "Useless use of grep iterator" */
1504 useless = OP_DESC(o);
1508 kid = cLISTOPo->op_first;
1509 if (kid && kid->op_type == OP_PUSHRE
1511 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1513 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1515 useless = OP_DESC(o);
1519 kid = cUNOPo->op_first;
1520 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1521 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1524 useless = "negative pattern binding (!~)";
1528 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1529 useless = "non-destructive substitution (s///r)";
1533 useless = "non-destructive transliteration (tr///r)";
1540 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1541 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1542 useless = "a variable";
1547 if (cSVOPo->op_private & OPpCONST_STRICT)
1548 no_bareword_allowed(o);
1550 if (ckWARN(WARN_VOID)) {
1551 /* don't warn on optimised away booleans, eg
1552 * use constant Foo, 5; Foo || print; */
1553 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1555 /* the constants 0 and 1 are permitted as they are
1556 conventionally used as dummies in constructs like
1557 1 while some_condition_with_side_effects; */
1558 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1560 else if (SvPOK(sv)) {
1561 SV * const dsv = newSVpvs("");
1563 = Perl_newSVpvf(aTHX_
1565 pv_pretty(dsv, SvPVX_const(sv),
1566 SvCUR(sv), 32, NULL, NULL,
1568 | PERL_PV_ESCAPE_NOCLEAR
1569 | PERL_PV_ESCAPE_UNI_DETECT));
1570 SvREFCNT_dec_NN(dsv);
1572 else if (SvOK(sv)) {
1573 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1576 useless = "a constant (undef)";
1579 op_null(o); /* don't execute or even remember it */
1583 o->op_type = OP_PREINC; /* pre-increment is faster */
1584 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1588 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1589 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1593 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1594 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1598 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1599 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1604 UNOP *refgen, *rv2cv;
1607 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1610 rv2gv = ((BINOP *)o)->op_last;
1611 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1614 refgen = (UNOP *)((BINOP *)o)->op_first;
1616 if (!refgen || refgen->op_type != OP_REFGEN)
1619 exlist = (LISTOP *)refgen->op_first;
1620 if (!exlist || exlist->op_type != OP_NULL
1621 || exlist->op_targ != OP_LIST)
1624 if (exlist->op_first->op_type != OP_PUSHMARK)
1627 rv2cv = (UNOP*)exlist->op_last;
1629 if (rv2cv->op_type != OP_RV2CV)
1632 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1633 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1634 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1636 o->op_private |= OPpASSIGN_CV_TO_GV;
1637 rv2gv->op_private |= OPpDONT_INIT_GV;
1638 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1650 kid = cLOGOPo->op_first;
1651 if (kid->op_type == OP_NOT
1652 && (kid->op_flags & OPf_KIDS)
1654 if (o->op_type == OP_AND) {
1656 o->op_ppaddr = PL_ppaddr[OP_OR];
1658 o->op_type = OP_AND;
1659 o->op_ppaddr = PL_ppaddr[OP_AND];
1668 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1673 if (o->op_flags & OPf_STACKED)
1680 if (!(o->op_flags & OPf_KIDS))
1691 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1702 /* mortalise it, in case warnings are fatal. */
1703 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1704 "Useless use of %"SVf" in void context",
1705 sv_2mortal(useless_sv));
1708 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1709 "Useless use of %s in void context",
1716 S_listkids(pTHX_ OP *o)
1718 if (o && o->op_flags & OPf_KIDS) {
1720 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1727 Perl_list(pTHX_ OP *o)
1732 /* assumes no premature commitment */
1733 if (!o || (o->op_flags & OPf_WANT)
1734 || (PL_parser && PL_parser->error_count)
1735 || o->op_type == OP_RETURN)
1740 if ((o->op_private & OPpTARGET_MY)
1741 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1743 return o; /* As if inside SASSIGN */
1746 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1748 switch (o->op_type) {
1751 list(cBINOPo->op_first);
1756 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1764 if (!(o->op_flags & OPf_KIDS))
1766 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1767 list(cBINOPo->op_first);
1768 return gen_constant_list(o);
1775 kid = cLISTOPo->op_first;
1777 kid = kid->op_sibling;
1780 OP *sib = kid->op_sibling;
1781 if (sib && kid->op_type != OP_LEAVEWHEN)
1787 PL_curcop = &PL_compiling;
1791 kid = cLISTOPo->op_first;
1798 S_scalarseq(pTHX_ OP *o)
1802 const OPCODE type = o->op_type;
1804 if (type == OP_LINESEQ || type == OP_SCOPE ||
1805 type == OP_LEAVE || type == OP_LEAVETRY)
1808 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1809 if (kid->op_sibling) {
1813 PL_curcop = &PL_compiling;
1815 o->op_flags &= ~OPf_PARENS;
1816 if (PL_hints & HINT_BLOCK_SCOPE)
1817 o->op_flags |= OPf_PARENS;
1820 o = newOP(OP_STUB, 0);
1825 S_modkids(pTHX_ OP *o, I32 type)
1827 if (o && o->op_flags & OPf_KIDS) {
1829 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1830 op_lvalue(kid, type);
1836 =for apidoc finalize_optree
1838 This function finalizes the optree. Should be called directly after
1839 the complete optree is built. It does some additional
1840 checking which can't be done in the normal ck_xxx functions and makes
1841 the tree thread-safe.
1846 Perl_finalize_optree(pTHX_ OP* o)
1848 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1851 SAVEVPTR(PL_curcop);
1859 S_finalize_op(pTHX_ OP* o)
1861 PERL_ARGS_ASSERT_FINALIZE_OP;
1863 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1865 /* Make sure mad ops are also thread-safe */
1866 MADPROP *mp = o->op_madprop;
1868 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1869 OP *prop_op = (OP *) mp->mad_val;
1870 /* We only need "Relocate sv to the pad for thread safety.", but this
1871 easiest way to make sure it traverses everything */
1872 if (prop_op->op_type == OP_CONST)
1873 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1874 finalize_op(prop_op);
1881 switch (o->op_type) {
1884 PL_curcop = ((COP*)o); /* for warnings */
1888 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1889 && ckWARN(WARN_EXEC))
1891 if (o->op_sibling->op_sibling) {
1892 const OPCODE type = o->op_sibling->op_sibling->op_type;
1893 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1894 const line_t oldline = CopLINE(PL_curcop);
1895 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1896 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1897 "Statement unlikely to be reached");
1898 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1899 "\t(Maybe you meant system() when you said exec()?)\n");
1900 CopLINE_set(PL_curcop, oldline);
1907 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1908 GV * const gv = cGVOPo_gv;
1909 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1910 /* XXX could check prototype here instead of just carping */
1911 SV * const sv = sv_newmortal();
1912 gv_efullname3(sv, gv, NULL);
1913 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1914 "%"SVf"() called too early to check prototype",
1921 if (cSVOPo->op_private & OPpCONST_STRICT)
1922 no_bareword_allowed(o);
1926 case OP_METHOD_NAMED:
1927 /* Relocate sv to the pad for thread safety.
1928 * Despite being a "constant", the SV is written to,
1929 * for reference counts, sv_upgrade() etc. */
1930 if (cSVOPo->op_sv) {
1931 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1932 SvREFCNT_dec(PAD_SVl(ix));
1933 PAD_SETSV(ix, cSVOPo->op_sv);
1934 /* XXX I don't know how this isn't readonly already. */
1935 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1936 cSVOPo->op_sv = NULL;
1950 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1953 rop = (UNOP*)((BINOP*)o)->op_first;
1958 S_scalar_slice_warning(aTHX_ o);
1961 kid = cLISTOPo->op_first->op_sibling;
1962 if (/* I bet there's always a pushmark... */
1963 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1964 && OP_TYPE_ISNT_NN(kid, OP_CONST))
1969 key_op = (SVOP*)(kid->op_type == OP_CONST
1971 : kLISTOP->op_first->op_sibling);
1973 rop = (UNOP*)((LISTOP*)o)->op_last;
1976 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1978 else if (rop->op_first->op_type == OP_PADSV)
1979 /* @$hash{qw(keys here)} */
1980 rop = (UNOP*)rop->op_first;
1982 /* @{$hash}{qw(keys here)} */
1983 if (rop->op_first->op_type == OP_SCOPE
1984 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1986 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1992 lexname = NULL; /* just to silence compiler warnings */
1993 fields = NULL; /* just to silence compiler warnings */
1997 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1998 SvPAD_TYPED(lexname))
1999 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2000 && isGV(*fields) && GvHV(*fields);
2002 key_op = (SVOP*)key_op->op_sibling) {
2004 if (key_op->op_type != OP_CONST)
2006 svp = cSVOPx_svp(key_op);
2008 /* Make the CONST have a shared SV */
2009 if ((!SvIsCOW_shared_hash(sv = *svp))
2010 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2012 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2013 SV *nsv = newSVpvn_share(key,
2014 SvUTF8(sv) ? -keylen : keylen, 0);
2015 SvREFCNT_dec_NN(sv);
2020 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2021 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2022 "in variable %"SVf" of type %"HEKf,
2023 SVfARG(*svp), SVfARG(lexname),
2024 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2030 S_scalar_slice_warning(aTHX_ o);
2034 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2035 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2042 if (o->op_flags & OPf_KIDS) {
2044 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2050 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2052 Propagate lvalue ("modifiable") context to an op and its children.
2053 I<type> represents the context type, roughly based on the type of op that
2054 would do the modifying, although C<local()> is represented by OP_NULL,
2055 because it has no op type of its own (it is signalled by a flag on
2058 This function detects things that can't be modified, such as C<$x+1>, and
2059 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2060 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2062 It also flags things that need to behave specially in an lvalue context,
2063 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2069 S_vivifies(const OPCODE type)
2072 case OP_RV2AV: case OP_ASLICE:
2073 case OP_RV2HV: case OP_KVASLICE:
2074 case OP_RV2SV: case OP_HSLICE:
2075 case OP_AELEMFAST: case OP_KVHSLICE:
2084 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2088 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2091 if (!o || (PL_parser && PL_parser->error_count))
2094 if ((o->op_private & OPpTARGET_MY)
2095 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2100 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2102 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2104 switch (o->op_type) {
2109 if ((o->op_flags & OPf_PARENS) || PL_madskills)
2113 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2114 !(o->op_flags & OPf_STACKED)) {
2115 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2116 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2117 poses, so we need it clear. */
2118 o->op_private &= ~1;
2119 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2120 assert(cUNOPo->op_first->op_type == OP_NULL);
2121 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2124 else { /* lvalue subroutine call */
2125 o->op_private |= OPpLVAL_INTRO
2126 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2127 PL_modcount = RETURN_UNLIMITED_NUMBER;
2128 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2129 /* Potential lvalue context: */
2130 o->op_private |= OPpENTERSUB_INARGS;
2133 else { /* Compile-time error message: */
2134 OP *kid = cUNOPo->op_first;
2137 if (kid->op_type != OP_PUSHMARK) {
2138 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2140 "panic: unexpected lvalue entersub "
2141 "args: type/targ %ld:%"UVuf,
2142 (long)kid->op_type, (UV)kid->op_targ);
2143 kid = kLISTOP->op_first;
2145 while (kid->op_sibling)
2146 kid = kid->op_sibling;
2147 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2148 break; /* Postpone until runtime */
2151 kid = kUNOP->op_first;
2152 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2153 kid = kUNOP->op_first;
2154 if (kid->op_type == OP_NULL)
2156 "Unexpected constant lvalue entersub "
2157 "entry via type/targ %ld:%"UVuf,
2158 (long)kid->op_type, (UV)kid->op_targ);
2159 if (kid->op_type != OP_GV) {
2163 cv = GvCV(kGVOP_gv);
2173 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2174 /* grep, foreach, subcalls, refgen */
2175 if (type == OP_GREPSTART || type == OP_ENTERSUB
2176 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2178 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2179 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2181 : (o->op_type == OP_ENTERSUB
2182 ? "non-lvalue subroutine call"
2184 type ? PL_op_desc[type] : "local"));
2198 case OP_RIGHT_SHIFT:
2207 if (!(o->op_flags & OPf_STACKED))
2214 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2215 op_lvalue(kid, type);
2220 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2221 PL_modcount = RETURN_UNLIMITED_NUMBER;
2222 return o; /* Treat \(@foo) like ordinary list. */
2226 if (scalar_mod_type(o, type))
2228 ref(cUNOPo->op_first, o->op_type);
2235 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2236 if (type == OP_LEAVESUBLV && (
2237 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2238 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2240 o->op_private |= OPpMAYBE_LVSUB;
2244 PL_modcount = RETURN_UNLIMITED_NUMBER;
2248 if (type == OP_LEAVESUBLV)
2249 o->op_private |= OPpMAYBE_LVSUB;
2252 PL_hints |= HINT_BLOCK_SCOPE;
2253 if (type == OP_LEAVESUBLV)
2254 o->op_private |= OPpMAYBE_LVSUB;
2258 ref(cUNOPo->op_first, o->op_type);
2262 PL_hints |= HINT_BLOCK_SCOPE;
2271 case OP_AELEMFAST_LEX:
2278 PL_modcount = RETURN_UNLIMITED_NUMBER;
2279 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2280 return o; /* Treat \(@foo) like ordinary list. */
2281 if (scalar_mod_type(o, type))
2283 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2284 && type == OP_LEAVESUBLV)
2285 o->op_private |= OPpMAYBE_LVSUB;
2289 if (!type) /* local() */
2290 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2291 PAD_COMPNAME_SV(o->op_targ));
2300 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2304 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2310 if (type == OP_LEAVESUBLV)
2311 o->op_private |= OPpMAYBE_LVSUB;
2312 if (o->op_flags & OPf_KIDS)
2313 op_lvalue(cBINOPo->op_first->op_sibling, type);
2318 ref(cBINOPo->op_first, o->op_type);
2319 if (type == OP_ENTERSUB &&
2320 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2321 o->op_private |= OPpLVAL_DEFER;
2322 if (type == OP_LEAVESUBLV)
2323 o->op_private |= OPpMAYBE_LVSUB;
2330 o->op_private |= OPpLVALUE;
2335 if (o->op_flags & OPf_KIDS)
2336 op_lvalue(cLISTOPo->op_last, type);
2341 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2343 else if (!(o->op_flags & OPf_KIDS))
2345 if (o->op_targ != OP_LIST) {
2346 op_lvalue(cBINOPo->op_first, type);
2352 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2353 /* elements might be in void context because the list is
2354 in scalar context or because they are attribute sub calls */
2355 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2356 op_lvalue(kid, type);
2360 if (type != OP_LEAVESUBLV)
2362 break; /* op_lvalue()ing was handled by ck_return() */
2369 if (type == OP_LEAVESUBLV
2370 || !S_vivifies(cLOGOPo->op_first->op_type))
2371 op_lvalue(cLOGOPo->op_first, type);
2372 if (type == OP_LEAVESUBLV
2373 || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2374 op_lvalue(cLOGOPo->op_first->op_sibling, type);
2378 /* [20011101.069] File test operators interpret OPf_REF to mean that
2379 their argument is a filehandle; thus \stat(".") should not set
2381 if (type == OP_REFGEN &&
2382 PL_check[o->op_type] == Perl_ck_ftst)
2385 if (type != OP_LEAVESUBLV)
2386 o->op_flags |= OPf_MOD;
2388 if (type == OP_AASSIGN || type == OP_SASSIGN)
2389 o->op_flags |= OPf_SPECIAL|OPf_REF;
2390 else if (!type) { /* local() */
2393 o->op_private |= OPpLVAL_INTRO;
2394 o->op_flags &= ~OPf_SPECIAL;
2395 PL_hints |= HINT_BLOCK_SCOPE;
2400 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2401 "Useless localization of %s", OP_DESC(o));
2404 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2405 && type != OP_LEAVESUBLV)
2406 o->op_flags |= OPf_REF;
2411 S_scalar_mod_type(const OP *o, I32 type)
2416 if (o && o->op_type == OP_RV2GV)
2440 case OP_RIGHT_SHIFT:
2461 S_is_handle_constructor(const OP *o, I32 numargs)
2463 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2465 switch (o->op_type) {
2473 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2486 S_refkids(pTHX_ OP *o, I32 type)
2488 if (o && o->op_flags & OPf_KIDS) {
2490 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2497 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2502 PERL_ARGS_ASSERT_DOREF;
2504 if (!o || (PL_parser && PL_parser->error_count))
2507 switch (o->op_type) {
2509 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2510 !(o->op_flags & OPf_STACKED)) {
2511 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2512 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2513 assert(cUNOPo->op_first->op_type == OP_NULL);
2514 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2515 o->op_flags |= OPf_SPECIAL;
2516 o->op_private &= ~1;
2518 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2519 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2520 : type == OP_RV2HV ? OPpDEREF_HV
2522 o->op_flags |= OPf_MOD;
2528 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2529 doref(kid, type, set_op_ref);
2532 if (type == OP_DEFINED)
2533 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2534 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2537 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2538 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2539 : type == OP_RV2HV ? OPpDEREF_HV
2541 o->op_flags |= OPf_MOD;
2548 o->op_flags |= OPf_REF;
2551 if (type == OP_DEFINED)
2552 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2553 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2559 o->op_flags |= OPf_REF;
2564 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2566 doref(cBINOPo->op_first, type, set_op_ref);
2570 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2571 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2572 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2573 : type == OP_RV2HV ? OPpDEREF_HV
2575 o->op_flags |= OPf_MOD;
2585 if (!(o->op_flags & OPf_KIDS))
2587 doref(cLISTOPo->op_last, type, set_op_ref);
2597 S_dup_attrlist(pTHX_ OP *o)
2602 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2604 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2605 * where the first kid is OP_PUSHMARK and the remaining ones
2606 * are OP_CONST. We need to push the OP_CONST values.
2608 if (o->op_type == OP_CONST)
2609 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2611 else if (o->op_type == OP_NULL)
2615 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2617 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2618 if (o->op_type == OP_CONST)
2619 rop = op_append_elem(OP_LIST, rop,
2620 newSVOP(OP_CONST, o->op_flags,
2621 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2628 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2631 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2633 PERL_ARGS_ASSERT_APPLY_ATTRS;
2635 /* fake up C<use attributes $pkg,$rv,@attrs> */
2637 #define ATTRSMODULE "attributes"
2638 #define ATTRSMODULE_PM "attributes.pm"
2640 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2641 newSVpvs(ATTRSMODULE),
2643 op_prepend_elem(OP_LIST,
2644 newSVOP(OP_CONST, 0, stashsv),
2645 op_prepend_elem(OP_LIST,
2646 newSVOP(OP_CONST, 0,
2648 dup_attrlist(attrs))));
2652 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2655 OP *pack, *imop, *arg;
2656 SV *meth, *stashsv, **svp;
2658 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2663 assert(target->op_type == OP_PADSV ||
2664 target->op_type == OP_PADHV ||
2665 target->op_type == OP_PADAV);
2667 /* Ensure that attributes.pm is loaded. */
2668 /* Don't force the C<use> if we don't need it. */
2669 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2670 if (svp && *svp != &PL_sv_undef)
2671 NOOP; /* already in %INC */
2673 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2674 newSVpvs(ATTRSMODULE), NULL);
2676 /* Need package name for method call. */
2677 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2679 /* Build up the real arg-list. */
2680 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2682 arg = newOP(OP_PADSV, 0);
2683 arg->op_targ = target->op_targ;
2684 arg = op_prepend_elem(OP_LIST,
2685 newSVOP(OP_CONST, 0, stashsv),
2686 op_prepend_elem(OP_LIST,
2687 newUNOP(OP_REFGEN, 0,
2688 op_lvalue(arg, OP_REFGEN)),
2689 dup_attrlist(attrs)));
2691 /* Fake up a method call to import */
2692 meth = newSVpvs_share("import");
2693 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2694 op_append_elem(OP_LIST,
2695 op_prepend_elem(OP_LIST, pack, list(arg)),
2696 newSVOP(OP_METHOD_NAMED, 0, meth)));
2698 /* Combine the ops. */
2699 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2703 =notfor apidoc apply_attrs_string
2705 Attempts to apply a list of attributes specified by the C<attrstr> and
2706 C<len> arguments to the subroutine identified by the C<cv> argument which
2707 is expected to be associated with the package identified by the C<stashpv>
2708 argument (see L<attributes>). It gets this wrong, though, in that it
2709 does not correctly identify the boundaries of the individual attribute
2710 specifications within C<attrstr>. This is not really intended for the
2711 public API, but has to be listed here for systems such as AIX which
2712 need an explicit export list for symbols. (It's called from XS code
2713 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2714 to respect attribute syntax properly would be welcome.
2720 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2721 const char *attrstr, STRLEN len)
2725 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2728 len = strlen(attrstr);
2732 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2734 const char * const sstr = attrstr;
2735 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2736 attrs = op_append_elem(OP_LIST, attrs,
2737 newSVOP(OP_CONST, 0,
2738 newSVpvn(sstr, attrstr-sstr)));
2742 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2743 newSVpvs(ATTRSMODULE),
2744 NULL, op_prepend_elem(OP_LIST,
2745 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2746 op_prepend_elem(OP_LIST,
2747 newSVOP(OP_CONST, 0,
2748 newRV(MUTABLE_SV(cv))),
2753 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2755 OP *new_proto = NULL;
2760 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2766 if (o->op_type == OP_CONST) {
2767 pv = SvPV(cSVOPo_sv, pvlen);
2768 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2769 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2770 SV ** const tmpo = cSVOPx_svp(o);
2771 SvREFCNT_dec(cSVOPo_sv);
2776 } else if (o->op_type == OP_LIST) {
2778 assert(o->op_flags & OPf_KIDS);
2779 assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2780 /* Counting on the first op to hit the lasto = o line */
2781 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2782 if (o->op_type == OP_CONST) {
2783 pv = SvPV(cSVOPo_sv, pvlen);
2784 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2785 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2786 SV ** const tmpo = cSVOPx_svp(o);
2787 SvREFCNT_dec(cSVOPo_sv);
2789 if (new_proto && ckWARN(WARN_MISC)) {
2791 const char * newp = SvPV(cSVOPo_sv, new_len);
2792 Perl_warner(aTHX_ packWARN(WARN_MISC),
2793 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2794 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2800 lasto->op_sibling = o->op_sibling;
2806 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2807 would get pulled in with no real need */
2808 if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2817 svname = sv_newmortal();
2818 gv_efullname3(svname, name, NULL);
2820 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2821 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2823 svname = (SV *)name;
2824 if (ckWARN(WARN_ILLEGALPROTO))
2825 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2826 if (*proto && ckWARN(WARN_PROTOTYPE)) {
2827 STRLEN old_len, new_len;
2828 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2829 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2831 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2832 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2834 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2835 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2845 S_cant_declare(pTHX_ OP *o)
2847 if (o->op_type == OP_NULL
2848 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2849 o = cUNOPo->op_first;
2850 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2851 o->op_type == OP_NULL
2852 && o->op_flags & OPf_SPECIAL
2855 PL_parser->in_my == KEY_our ? "our" :
2856 PL_parser->in_my == KEY_state ? "state" :
2861 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2865 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2867 PERL_ARGS_ASSERT_MY_KID;
2869 if (!o || (PL_parser && PL_parser->error_count))
2873 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2874 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2878 if (type == OP_LIST) {
2880 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2881 my_kid(kid, attrs, imopsp);
2883 } else if (type == OP_UNDEF || type == OP_STUB) {
2885 } else if (type == OP_RV2SV || /* "our" declaration */
2887 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2888 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2889 S_cant_declare(aTHX_ o);
2891 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2892 PL_parser->in_my = FALSE;
2893 PL_parser->in_my_stash = NULL;
2894 apply_attrs(GvSTASH(gv),
2895 (type == OP_RV2SV ? GvSV(gv) :
2896 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2897 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2900 o->op_private |= OPpOUR_INTRO;
2903 else if (type != OP_PADSV &&
2906 type != OP_PUSHMARK)
2908 S_cant_declare(aTHX_ o);
2911 else if (attrs && type != OP_PUSHMARK) {
2914 PL_parser->in_my = FALSE;
2915 PL_parser->in_my_stash = NULL;
2917 /* check for C<my Dog $spot> when deciding package */
2918 stash = PAD_COMPNAME_TYPE(o->op_targ);
2920 stash = PL_curstash;
2921 apply_attrs_my(stash, o, attrs, imopsp);
2923 o->op_flags |= OPf_MOD;
2924 o->op_private |= OPpLVAL_INTRO;
2926 o->op_private |= OPpPAD_STATE;
2931 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2935 int maybe_scalar = 0;
2937 PERL_ARGS_ASSERT_MY_ATTRS;
2939 /* [perl #17376]: this appears to be premature, and results in code such as
2940 C< our(%x); > executing in list mode rather than void mode */
2942 if (o->op_flags & OPf_PARENS)
2952 o = my_kid(o, attrs, &rops);
2954 if (maybe_scalar && o->op_type == OP_PADSV) {
2955 o = scalar(op_append_list(OP_LIST, rops, o));
2956 o->op_private |= OPpLVAL_INTRO;
2959 /* The listop in rops might have a pushmark at the beginning,
2960 which will mess up list assignment. */
2961 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2962 if (rops->op_type == OP_LIST &&
2963 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2965 OP * const pushmark = lrops->op_first;
2966 lrops->op_first = pushmark->op_sibling;
2969 o = op_append_list(OP_LIST, o, rops);
2972 PL_parser->in_my = FALSE;
2973 PL_parser->in_my_stash = NULL;
2978 Perl_sawparens(pTHX_ OP *o)
2980 PERL_UNUSED_CONTEXT;
2982 o->op_flags |= OPf_PARENS;
2987 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2991 const OPCODE ltype = left->op_type;
2992 const OPCODE rtype = right->op_type;
2994 PERL_ARGS_ASSERT_BIND_MATCH;
2996 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2997 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2999 const char * const desc
3001 rtype == OP_SUBST || rtype == OP_TRANS
3002 || rtype == OP_TRANSR
3004 ? (int)rtype : OP_MATCH];
3005 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3007 S_op_varname(aTHX_ left);
3009 Perl_warner(aTHX_ packWARN(WARN_MISC),
3010 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3013 const char * const sample = (isary
3014 ? "@array" : "%hash");
3015 Perl_warner(aTHX_ packWARN(WARN_MISC),
3016 "Applying %s to %s will act on scalar(%s)",
3017 desc, sample, sample);
3021 if (rtype == OP_CONST &&
3022 cSVOPx(right)->op_private & OPpCONST_BARE &&
3023 cSVOPx(right)->op_private & OPpCONST_STRICT)
3025 no_bareword_allowed(right);
3028 /* !~ doesn't make sense with /r, so error on it for now */
3029 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3031 /* diag_listed_as: Using !~ with %s doesn't make sense */
3032 yyerror("Using !~ with s///r doesn't make sense");
3033 if (rtype == OP_TRANSR && type == OP_NOT)
3034 /* diag_listed_as: Using !~ with %s doesn't make sense */
3035 yyerror("Using !~ with tr///r doesn't make sense");
3037 ismatchop = (rtype == OP_MATCH ||
3038 rtype == OP_SUBST ||
3039 rtype == OP_TRANS || rtype == OP_TRANSR)
3040 && !(right->op_flags & OPf_SPECIAL);
3041 if (ismatchop && right->op_private & OPpTARGET_MY) {
3043 right->op_private &= ~OPpTARGET_MY;
3045 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3048 right->op_flags |= OPf_STACKED;
3049 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3050 ! (rtype == OP_TRANS &&
3051 right->op_private & OPpTRANS_IDENTICAL) &&
3052 ! (rtype == OP_SUBST &&
3053 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3054 newleft = op_lvalue(left, rtype);
3057 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3058 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3060 o = op_prepend_elem(rtype, scalar(newleft), right);
3062 return newUNOP(OP_NOT, 0, scalar(o));
3066 return bind_match(type, left,
3067 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3071 Perl_invert(pTHX_ OP *o)
3075 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3079 =for apidoc Amx|OP *|op_scope|OP *o
3081 Wraps up an op tree with some additional ops so that at runtime a dynamic
3082 scope will be created. The original ops run in the new dynamic scope,
3083 and then, provided that they exit normally, the scope will be unwound.
3084 The additional ops used to create and unwind the dynamic scope will
3085 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3086 instead if the ops are simple enough to not need the full dynamic scope
3093 Perl_op_scope(pTHX_ OP *o)
3097 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3098 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3099 o->op_type = OP_LEAVE;
3100 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3102 else if (o->op_type == OP_LINESEQ) {
3104 o->op_type = OP_SCOPE;
3105 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3106 kid = ((LISTOP*)o)->op_first;
3107 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3110 /* The following deals with things like 'do {1 for 1}' */
3111 kid = kid->op_sibling;
3113 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3118 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3124 Perl_op_unscope(pTHX_ OP *o)
3126 if (o && o->op_type == OP_LINESEQ) {
3127 OP *kid = cLISTOPo->op_first;
3128 for(; kid; kid = kid->op_sibling)
3129 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3136 Perl_block_start(pTHX_ int full)
3139 const int retval = PL_savestack_ix;
3141 pad_block_start(full);
3143 PL_hints &= ~HINT_BLOCK_SCOPE;
3144 SAVECOMPILEWARNINGS();
3145 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3147 CALL_BLOCK_HOOKS(bhk_start, full);
3153 Perl_block_end(pTHX_ I32 floor, OP *seq)
3156 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3157 OP* retval = scalarseq(seq);
3160 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3164 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3168 /* pad_leavemy has created a sequence of introcv ops for all my
3169 subs declared in the block. We have to replicate that list with
3170 clonecv ops, to deal with this situation:
3175 sub s1 { state sub foo { \&s2 } }
3178 Originally, I was going to have introcv clone the CV and turn
3179 off the stale flag. Since &s1 is declared before &s2, the
3180 introcv op for &s1 is executed (on sub entry) before the one for
3181 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3182 cloned, since it is a state sub) closes over &s2 and expects
3183 to see it in its outer CV’s pad. If the introcv op clones &s1,
3184 then &s2 is still marked stale. Since &s1 is not active, and
3185 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3186 ble will not stay shared’ warning. Because it is the same stub
3187 that will be used when the introcv op for &s2 is executed, clos-
3188 ing over it is safe. Hence, we have to turn off the stale flag
3189 on all lexical subs in the block before we clone any of them.
3190 Hence, having introcv clone the sub cannot work. So we create a
3191 list of ops like this:
3215 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3216 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3217 for (;; kid = kid->op_sibling) {
3218 OP *newkid = newOP(OP_CLONECV, 0);
3219 newkid->op_targ = kid->op_targ;
3220 o = op_append_elem(OP_LINESEQ, o, newkid);
3221 if (kid == last) break;
3223 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3226 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3232 =head1 Compile-time scope hooks
3234 =for apidoc Aox||blockhook_register
3236 Register a set of hooks to be called when the Perl lexical scope changes
3237 at compile time. See L<perlguts/"Compile-time scope hooks">.
3243 Perl_blockhook_register(pTHX_ BHK *hk)
3245 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3247 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3254 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3255 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3256 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3259 OP * const o = newOP(OP_PADSV, 0);
3260 o->op_targ = offset;
3266 Perl_newPROG(pTHX_ OP *o)
3270 PERL_ARGS_ASSERT_NEWPROG;
3277 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3278 ((PL_in_eval & EVAL_KEEPERR)
3279 ? OPf_SPECIAL : 0), o);
3281 cx = &cxstack[cxstack_ix];
3282 assert(CxTYPE(cx) == CXt_EVAL);
3284 if ((cx->blk_gimme & G_WANT) == G_VOID)
3285 scalarvoid(PL_eval_root);
3286 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3289 scalar(PL_eval_root);
3291 PL_eval_start = op_linklist(PL_eval_root);
3292 PL_eval_root->op_private |= OPpREFCOUNTED;
3293 OpREFCNT_set(PL_eval_root, 1);
3294 PL_eval_root->op_next = 0;
3295 i = PL_savestack_ix;
3298 CALL_PEEP(PL_eval_start);
3299 finalize_optree(PL_eval_root);
3301 PL_savestack_ix = i;
3304 if (o->op_type == OP_STUB) {
3305 /* This block is entered if nothing is compiled for the main
3306 program. This will be the case for an genuinely empty main
3307 program, or one which only has BEGIN blocks etc, so already
3310 Historically (5.000) the guard above was !o. However, commit
3311 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3312 c71fccf11fde0068, changed perly.y so that newPROG() is now
3313 called with the output of block_end(), which returns a new
3314 OP_STUB for the case of an empty optree. ByteLoader (and
3315 maybe other things) also take this path, because they set up
3316 PL_main_start and PL_main_root directly, without generating an
3319 If the parsing the main program aborts (due to parse errors,
3320 or due to BEGIN or similar calling exit), then newPROG()
3321 isn't even called, and hence this code path and its cleanups
3322 are skipped. This shouldn't make a make a difference:
3323 * a non-zero return from perl_parse is a failure, and
3324 perl_destruct() should be called immediately.
3325 * however, if exit(0) is called during the parse, then
3326 perl_parse() returns 0, and perl_run() is called. As
3327 PL_main_start will be NULL, perl_run() will return
3328 promptly, and the exit code will remain 0.
3331 PL_comppad_name = 0;
3333 S_op_destroy(aTHX_ o);
3336 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3337 PL_curcop = &PL_compiling;
3338 PL_main_start = LINKLIST(PL_main_root);
3339 PL_main_root->op_private |= OPpREFCOUNTED;
3340 OpREFCNT_set(PL_main_root, 1);
3341 PL_main_root->op_next = 0;
3342 CALL_PEEP(PL_main_start);
3343 finalize_optree(PL_main_root);
3344 cv_forget_slab(PL_compcv);
3347 /* Register with debugger */
3349 CV * const cv = get_cvs("DB::postponed", 0);
3353 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3355 call_sv(MUTABLE_SV(cv), G_DISCARD);
3362 Perl_localize(pTHX_ OP *o, I32 lex)
3366 PERL_ARGS_ASSERT_LOCALIZE;
3368 if (o->op_flags & OPf_PARENS)
3369 /* [perl #17376]: this appears to be premature, and results in code such as
3370 C< our(%x); > executing in list mode rather than void mode */
3377 if ( PL_parser->bufptr > PL_parser->oldbufptr
3378 && PL_parser->bufptr[-1] == ','
3379 && ckWARN(WARN_PARENTHESIS))
3381 char *s = PL_parser->bufptr;
3384 /* some heuristics to detect a potential error */
3385 while (*s && (strchr(", \t\n", *s)))
3389 if (*s && strchr("@$%*", *s) && *++s
3390 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3393 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3395 while (*s && (strchr(", \t\n", *s)))
3401 if (sigil && (*s == ';' || *s == '=')) {
3402 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3403 "Parentheses missing around \"%s\" list",
3405 ? (PL_parser->in_my == KEY_our
3407 : PL_parser->in_my == KEY_state
3417 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3418 PL_parser->in_my = FALSE;
3419 PL_parser->in_my_stash = NULL;
3424 Perl_jmaybe(pTHX_ OP *o)
3426 PERL_ARGS_ASSERT_JMAYBE;
3428 if (o->op_type == OP_LIST) {
3430 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3431 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3436 PERL_STATIC_INLINE OP *
3437 S_op_std_init(pTHX_ OP *o)
3439 I32 type = o->op_type;
3441 PERL_ARGS_ASSERT_OP_STD_INIT;
3443 if (PL_opargs[type] & OA_RETSCALAR)
3445 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3446 o->op_targ = pad_alloc(type, SVs_PADTMP);
3451 PERL_STATIC_INLINE OP *
3452 S_op_integerize(pTHX_ OP *o)
3454 I32 type = o->op_type;
3456 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3458 /* integerize op. */
3459 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3462 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3465 if (type == OP_NEGATE)
3466 /* XXX might want a ck_negate() for this */
3467 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3473 S_fold_constants(pTHX_ OP *o)
3478 VOL I32 type = o->op_type;
3483 SV * const oldwarnhook = PL_warnhook;
3484 SV * const olddiehook = PL_diehook;
3488 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3490 if (!(PL_opargs[type] & OA_FOLDCONST))
3505 /* XXX what about the numeric ops? */
3506 if (IN_LOCALE_COMPILETIME)
3510 if (!cLISTOPo->op_first->op_sibling
3511 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3514 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3515 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3517 const char *s = SvPVX_const(sv);
3518 while (s < SvEND(sv)) {
3519 if (*s == 'p' || *s == 'P') goto nope;
3526 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3529 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3530 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3534 if (PL_parser && PL_parser->error_count)
3535 goto nope; /* Don't try to run w/ errors */
3537 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3538 const OPCODE type = curop->op_type;
3539 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3541 type != OP_SCALAR &&
3543 type != OP_PUSHMARK)
3549 curop = LINKLIST(o);
3550 old_next = o->op_next;
3554 oldscope = PL_scopestack_ix;
3555 create_eval_scope(G_FAKINGEVAL);
3557 /* Verify that we don't need to save it: */
3558 assert(PL_curcop == &PL_compiling);
3559 StructCopy(&PL_compiling, ¬_compiling, COP);
3560 PL_curcop = ¬_compiling;
3561 /* The above ensures that we run with all the correct hints of the
3562 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3563 assert(IN_PERL_RUNTIME);
3564 PL_warnhook = PERL_WARNHOOK_FATAL;
3571 sv = *(PL_stack_sp--);
3572 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3574 /* Can't simply swipe the SV from the pad, because that relies on
3575 the op being freed "real soon now". Under MAD, this doesn't
3576 happen (see the #ifdef below). */
3579 pad_swipe(o->op_targ, FALSE);
3582 else if (SvTEMP(sv)) { /* grab mortal temp? */
3583 SvREFCNT_inc_simple_void(sv);
3586 else { assert(SvIMMORTAL(sv)); }
3589 /* Something tried to die. Abandon constant folding. */
3590 /* Pretend the error never happened. */
3592 o->op_next = old_next;
3596 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3597 PL_warnhook = oldwarnhook;
3598 PL_diehook = olddiehook;
3599 /* XXX note that this croak may fail as we've already blown away
3600 * the stack - eg any nested evals */
3601 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3604 PL_warnhook = oldwarnhook;
3605 PL_diehook = olddiehook;
3606 PL_curcop = &PL_compiling;
3608 if (PL_scopestack_ix > oldscope)
3609 delete_eval_scope();
3618 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3619 else if (!SvIMMORTAL(sv)) {
3623 if (type == OP_RV2GV)
3624 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3627 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3628 if (type != OP_STRINGIFY) newop->op_folded = 1;
3630 op_getmad(o,newop,'f');
3638 S_gen_constant_list(pTHX_ OP *o)
3642 const SSize_t oldtmps_floor = PL_tmps_floor;
3647 if (PL_parser && PL_parser->error_count)
3648 return o; /* Don't attempt to run with errors */
3650 PL_op = curop = LINKLIST(o);
3653 Perl_pp_pushmark(aTHX);
3656 assert (!(curop->op_flags & OPf_SPECIAL));
3657 assert(curop->op_type == OP_RANGE);
3658 Perl_pp_anonlist(aTHX);
3659 PL_tmps_floor = oldtmps_floor;
3661 o->op_type = OP_RV2AV;
3662 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3663 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3664 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3665 o->op_opt = 0; /* needs to be revisited in rpeep() */
3666 curop = ((UNOP*)o)->op_first;
3667 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3668 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3669 if (AvFILLp(av) != -1)
3670 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3673 SvREADONLY_on(*svp);
3676 op_getmad(curop,o,'O');
3685 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3688 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3689 if (!o || o->op_type != OP_LIST)
3690 o = newLISTOP(OP_LIST, 0, o, NULL);
3692 o->op_flags &= ~OPf_WANT;
3694 if (!(PL_opargs[type] & OA_MARK))
3695 op_null(cLISTOPo->op_first);
3697 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3698 if (kid2 && kid2->op_type == OP_COREARGS) {
3699 op_null(cLISTOPo->op_first);
3700 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3704 o->op_type = (OPCODE)type;
3705 o->op_ppaddr = PL_ppaddr[type];
3706 o->op_flags |= flags;
3708 o = CHECKOP(type, o);
3709 if (o->op_type != (unsigned)type)
3712 return fold_constants(op_integerize(op_std_init(o)));
3716 =head1 Optree Manipulation Functions
3719 /* List constructors */
3722 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3724 Append an item to the list of ops contained directly within a list-type
3725 op, returning the lengthened list. I<first> is the list-type op,
3726 and I<last> is the op to append to the list. I<optype> specifies the
3727 intended opcode for the list. If I<first> is not already a list of the
3728 right type, it will be upgraded into one. If either I<first> or I<last>
3729 is null, the other is returned unchanged.
3735 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3743 if (first->op_type != (unsigned)type
3744 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3746 return newLISTOP(type, 0, first, last);
3749 if (first->op_flags & OPf_KIDS)
3750 ((LISTOP*)first)->op_last->op_sibling = last;
3752 first->op_flags |= OPf_KIDS;
3753 ((LISTOP*)first)->op_first = last;
3755 ((LISTOP*)first)->op_last = last;
3760 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3762 Concatenate the lists of ops contained directly within two list-type ops,
3763 returning the combined list. I<first> and I<last> are the list-type ops
3764 to concatenate. I<optype> specifies the intended opcode for the list.
3765 If either I<first> or I<last> is not already a list of the right type,
3766 it will be upgraded into one. If either I<first> or I<last> is null,
3767 the other is returned unchanged.
3773 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3781 if (first->op_type != (unsigned)type)
3782 return op_prepend_elem(type, first, last);
3784 if (last->op_type != (unsigned)type)
3785 return op_append_elem(type, first, last);
3787 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3788 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3789 first->op_flags |= (last->op_flags & OPf_KIDS);
3792 if (((LISTOP*)last)->op_first && first->op_madprop) {
3793 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3795 while (mp->mad_next)
3797 mp->mad_next = first->op_madprop;
3800 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3803 first->op_madprop = last->op_madprop;
3804 last->op_madprop = 0;
3807 S_op_destroy(aTHX_ last);
3813 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3815 Prepend an item to the list of ops contained directly within a list-type
3816 op, returning the lengthened list. I<first> is the op to prepend to the
3817 list, and I<last> is the list-type op. I<optype> specifies the intended
3818 opcode for the list. If I<last> is not already a list of the right type,
3819 it will be upgraded into one. If either I<first> or I<last> is null,
3820 the other is returned unchanged.
3826 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3834 if (last->op_type == (unsigned)type) {
3835 if (type == OP_LIST) { /* already a PUSHMARK there */
3836 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3837 ((LISTOP*)last)->op_first->op_sibling = first;
3838 if (!(first->op_flags & OPf_PARENS))
3839 last->op_flags &= ~OPf_PARENS;
3842 if (!(last->op_flags & OPf_KIDS)) {
3843 ((LISTOP*)last)->op_last = first;
3844 last->op_flags |= OPf_KIDS;
3846 first->op_sibling = ((LISTOP*)last)->op_first;
3847 ((LISTOP*)last)->op_first = first;
3849 last->op_flags |= OPf_KIDS;
3853 return newLISTOP(type, 0, first, last);
3861 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3864 Newxz(tk, 1, TOKEN);
3865 tk->tk_type = (OPCODE)optype;
3866 tk->tk_type = 12345;
3868 tk->tk_mad = madprop;
3873 Perl_token_free(pTHX_ TOKEN* tk)
3875 PERL_ARGS_ASSERT_TOKEN_FREE;
3877 if (tk->tk_type != 12345)
3879 mad_free(tk->tk_mad);
3884 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3889 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3891 if (tk->tk_type != 12345) {
3892 Perl_warner(aTHX_ packWARN(WARN_MISC),
3893 "Invalid TOKEN object ignored");
3900 /* faked up qw list? */
3902 tm->mad_type == MAD_SV &&
3903 SvPVX((SV *)tm->mad_val)[0] == 'q')
3910 /* pretend constant fold didn't happen? */
3911 if (mp->mad_key == 'f' &&
3912 (o->op_type == OP_CONST ||
3913 o->op_type == OP_GV) )
3915 token_getmad(tk,(OP*)mp->mad_val,slot);
3929 if (mp->mad_key == 'X')
3930 mp->mad_key = slot; /* just change the first one */
3940 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3949 /* pretend constant fold didn't happen? */
3950 if (mp->mad_key == 'f' &&
3951 (o->op_type == OP_CONST ||
3952 o->op_type == OP_GV) )
3954 op_getmad(from,(OP*)mp->mad_val,slot);
3961 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3964 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3970 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3979 /* pretend constant fold didn't happen? */
3980 if (mp->mad_key == 'f' &&
3981 (o->op_type == OP_CONST ||
3982 o->op_type == OP_GV) )
3984 op_getmad(from,(OP*)mp->mad_val,slot);
3991 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3994 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3998 PerlIO_printf(PerlIO_stderr(),
3999 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
4005 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
4023 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
4027 addmad(tm, &(o->op_madprop), slot);
4031 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
4052 Perl_newMADsv(pTHX_ char key, SV* sv)
4054 PERL_ARGS_ASSERT_NEWMADSV;
4056 return newMADPROP(key, MAD_SV, sv, 0);
4060 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
4062 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
4065 mp->mad_vlen = vlen;
4066 mp->mad_type = type;
4068 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
4073 Perl_mad_free(pTHX_ MADPROP* mp)
4075 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
4079 mad_free(mp->mad_next);
4080 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
4081 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
4082 switch (mp->mad_type) {
4086 Safefree(mp->mad_val);
4089 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
4090 op_free((OP*)mp->mad_val);
4093 sv_free(MUTABLE_SV(mp->mad_val));
4096 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
4099 PerlMemShared_free(mp);
4105 =head1 Optree construction
4107 =for apidoc Am|OP *|newNULLLIST
4109 Constructs, checks, and returns a new C<stub> op, which represents an
4110 empty list expression.
4116 Perl_newNULLLIST(pTHX)
4118 return newOP(OP_STUB, 0);
4122 S_force_list(pTHX_ OP *o)
4124 if (!o || o->op_type != OP_LIST)
4125 o = newLISTOP(OP_LIST, 0, o, NULL);
4131 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4133 Constructs, checks, and returns an op of any list type. I<type> is
4134 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4135 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4136 supply up to two ops to be direct children of the list op; they are
4137 consumed by this function and become part of the constructed op tree.
4143 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4148 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4150 NewOp(1101, listop, 1, LISTOP);
4152 listop->op_type = (OPCODE)type;
4153 listop->op_ppaddr = PL_ppaddr[type];
4156 listop->op_flags = (U8)flags;
4160 else if (!first && last)
4163 first->op_sibling = last;
4164 listop->op_first = first;
4165 listop->op_last = last;
4166 if (type == OP_LIST) {
4167 OP* const pushop = newOP(OP_PUSHMARK, 0);
4168 pushop->op_sibling = first;
4169 listop->op_first = pushop;
4170 listop->op_flags |= OPf_KIDS;
4172 listop->op_last = pushop;
4175 return CHECKOP(type, listop);
4179 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4181 Constructs, checks, and returns an op of any base type (any type that
4182 has no extra fields). I<type> is the opcode. I<flags> gives the
4183 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4190 Perl_newOP(pTHX_ I32 type, I32 flags)
4195 if (type == -OP_ENTEREVAL) {
4196 type = OP_ENTEREVAL;
4197 flags |= OPpEVAL_BYTES<<8;
4200 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4201 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4202 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4203 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4205 NewOp(1101, o, 1, OP);
4206 o->op_type = (OPCODE)type;
4207 o->op_ppaddr = PL_ppaddr[type];
4208 o->op_flags = (U8)flags;
4211 o->op_private = (U8)(0 | (flags >> 8));
4212 if (PL_opargs[type] & OA_RETSCALAR)
4214 if (PL_opargs[type] & OA_TARGET)
4215 o->op_targ = pad_alloc(type, SVs_PADTMP);
4216 return CHECKOP(type, o);
4220 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4222 Constructs, checks, and returns an op of any unary type. I<type> is
4223 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4224 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4225 bits, the eight bits of C<op_private>, except that the bit with value 1
4226 is automatically set. I<first> supplies an optional op to be the direct
4227 child of the unary op; it is consumed by this function and become part
4228 of the constructed op tree.
4234 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4239 if (type == -OP_ENTEREVAL) {
4240 type = OP_ENTEREVAL;
4241 flags |= OPpEVAL_BYTES<<8;
4244 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4245 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4246 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4247 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4248 || type == OP_SASSIGN
4249 || type == OP_ENTERTRY
4250 || type == OP_NULL );
4253 first = newOP(OP_STUB, 0);
4254 if (PL_opargs[type] & OA_MARK)
4255 first = force_list(first);
4257 NewOp(1101, unop, 1, UNOP);
4258 unop->op_type = (OPCODE)type;
4259 unop->op_ppaddr = PL_ppaddr[type];
4260 unop->op_first = first;
4261 unop->op_flags = (U8)(flags | OPf_KIDS);
4262 unop->op_private = (U8)(1 | (flags >> 8));
4263 unop = (UNOP*) CHECKOP(type, unop);
4267 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4271 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4273 Constructs, checks, and returns an op of any binary type. I<type>
4274 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4275 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4276 the eight bits of C<op_private>, except that the bit with value 1 or
4277 2 is automatically set as required. I<first> and I<last> supply up to
4278 two ops to be the direct children of the binary op; they are consumed
4279 by this function and become part of the constructed op tree.
4285 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4290 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4291 || type == OP_SASSIGN || type == OP_NULL );
4293 NewOp(1101, binop, 1, BINOP);
4296 first = newOP(OP_NULL, 0);
4298 binop->op_type = (OPCODE)type;
4299 binop->op_ppaddr = PL_ppaddr[type];
4300 binop->op_first = first;
4301 binop->op_flags = (U8)(flags | OPf_KIDS);
4304 binop->op_private = (U8)(1 | (flags >> 8));
4307 binop->op_private = (U8)(2 | (flags >> 8));
4308 first->op_sibling = last;
4311 binop = (BINOP*)CHECKOP(type, binop);
4312 if (binop->op_next || binop->op_type != (OPCODE)type)
4315 binop->op_last = binop->op_first->op_sibling;
4317 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4320 static int uvcompare(const void *a, const void *b)
4321 __attribute__nonnull__(1)
4322 __attribute__nonnull__(2)
4323 __attribute__pure__;
4324 static int uvcompare(const void *a, const void *b)
4326 if (*((const UV *)a) < (*(const UV *)b))
4328 if (*((const UV *)a) > (*(const UV *)b))
4330 if (*((const UV *)a+1) < (*(const UV *)b+1))
4332 if (*((const UV *)a+1) > (*(const UV *)b+1))
4338 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4341 SV * const tstr = ((SVOP*)expr)->op_sv;
4344 (repl->op_type == OP_NULL)
4345 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4347 ((SVOP*)repl)->op_sv;
4350 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4351 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4357 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4358 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4359 I32 del = o->op_private & OPpTRANS_DELETE;
4362 PERL_ARGS_ASSERT_PMTRANS;
4364 PL_hints |= HINT_BLOCK_SCOPE;
4367 o->op_private |= OPpTRANS_FROM_UTF;
4370 o->op_private |= OPpTRANS_TO_UTF;
4372 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4373 SV* const listsv = newSVpvs("# comment\n");
4375 const U8* tend = t + tlen;
4376 const U8* rend = r + rlen;
4390 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4391 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4394 const U32 flags = UTF8_ALLOW_DEFAULT;
4398 t = tsave = bytes_to_utf8(t, &len);
4401 if (!to_utf && rlen) {
4403 r = rsave = bytes_to_utf8(r, &len);
4407 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4408 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4412 U8 tmpbuf[UTF8_MAXBYTES+1];
4415 Newx(cp, 2*tlen, UV);
4417 transv = newSVpvs("");
4419 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4421 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4423 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4427 cp[2*i+1] = cp[2*i];
4431 qsort(cp, i, 2*sizeof(UV), uvcompare);
4432 for (j = 0; j < i; j++) {
4434 diff = val - nextmin;
4436 t = uvchr_to_utf8(tmpbuf,nextmin);
4437 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4439 U8 range_mark = ILLEGAL_UTF8_BYTE;
4440 t = uvchr_to_utf8(tmpbuf, val - 1);
4441 sv_catpvn(transv, (char *)&range_mark, 1);
4442 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4449 t = uvchr_to_utf8(tmpbuf,nextmin);
4450 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4452 U8 range_mark = ILLEGAL_UTF8_BYTE;
4453 sv_catpvn(transv, (char *)&range_mark, 1);
4455 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4456 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4457 t = (const U8*)SvPVX_const(transv);
4458 tlen = SvCUR(transv);
4462 else if (!rlen && !del) {
4463 r = t; rlen = tlen; rend = tend;
4466 if ((!rlen && !del) || t == r ||
4467 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4469 o->op_private |= OPpTRANS_IDENTICAL;
4473 while (t < tend || tfirst <= tlast) {
4474 /* see if we need more "t" chars */
4475 if (tfirst > tlast) {
4476 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4478 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4480 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4487 /* now see if we need more "r" chars */
4488 if (rfirst > rlast) {
4490 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4492 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4494 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4503 rfirst = rlast = 0xffffffff;
4507 /* now see which range will peter our first, if either. */
4508 tdiff = tlast - tfirst;
4509 rdiff = rlast - rfirst;
4516 if (rfirst == 0xffffffff) {
4517 diff = tdiff; /* oops, pretend rdiff is infinite */
4519 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4520 (long)tfirst, (long)tlast);
4522 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4526 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4527 (long)tfirst, (long)(tfirst + diff),
4530 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4531 (long)tfirst, (long)rfirst);
4533 if (rfirst + diff > max)
4534 max = rfirst + diff;
4536 grows = (tfirst < rfirst &&
4537 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4549 else if (max > 0xff)
4554 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4556 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4557 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4558 PAD_SETSV(cPADOPo->op_padix, swash);
4560 SvREADONLY_on(swash);
4562 cSVOPo->op_sv = swash;
4564 SvREFCNT_dec(listsv);
4565 SvREFCNT_dec(transv);
4567 if (!del && havefinal && rlen)
4568 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4569 newSVuv((UV)final), 0);
4572 o->op_private |= OPpTRANS_GROWS;
4578 op_getmad(expr,o,'e');
4579 op_getmad(repl,o,'r');
4587 tbl = (short*)PerlMemShared_calloc(
4588 (o->op_private & OPpTRANS_COMPLEMENT) &&
4589 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4591 cPVOPo->op_pv = (char*)tbl;
4593 for (i = 0; i < (I32)tlen; i++)
4595 for (i = 0, j = 0; i < 256; i++) {
4597 if (j >= (I32)rlen) {
4606 if (i < 128 && r[j] >= 128)
4616 o->op_private |= OPpTRANS_IDENTICAL;
4618 else if (j >= (I32)rlen)
4623 PerlMemShared_realloc(tbl,
4624 (0x101+rlen-j) * sizeof(short));
4625 cPVOPo->op_pv = (char*)tbl;
4627 tbl[0x100] = (short)(rlen - j);
4628 for (i=0; i < (I32)rlen - j; i++)
4629 tbl[0x101+i] = r[j+i];
4633 if (!rlen && !del) {
4636 o->op_private |= OPpTRANS_IDENTICAL;
4638 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4639 o->op_private |= OPpTRANS_IDENTICAL;
4641 for (i = 0; i < 256; i++)
4643 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4644 if (j >= (I32)rlen) {
4646 if (tbl[t[i]] == -1)
4652 if (tbl[t[i]] == -1) {
4653 if (t[i] < 128 && r[j] >= 128)
4660 if(del && rlen == tlen) {
4661 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4662 } else if(rlen > tlen && !complement) {
4663 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4667 o->op_private |= OPpTRANS_GROWS;
4669 op_getmad(expr,o,'e');
4670 op_getmad(repl,o,'r');
4680 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4682 Constructs, checks, and returns an op of any pattern matching type.
4683 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4684 and, shifted up eight bits, the eight bits of C<op_private>.
4690 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4695 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4697 NewOp(1101, pmop, 1, PMOP);
4698 pmop->op_type = (OPCODE)type;
4699 pmop->op_ppaddr = PL_ppaddr[type];
4700 pmop->op_flags = (U8)flags;
4701 pmop->op_private = (U8)(0 | (flags >> 8));
4703 if (PL_hints & HINT_RE_TAINT)
4704 pmop->op_pmflags |= PMf_RETAINT;
4705 if (IN_LOCALE_COMPILETIME) {
4706 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4708 else if ((! (PL_hints & HINT_BYTES))
4709 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4710 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4712 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4714 if (PL_hints & HINT_RE_FLAGS) {
4715 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4716 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4718 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4719 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4720 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4722 if (reflags && SvOK(reflags)) {
4723 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4729 assert(SvPOK(PL_regex_pad[0]));
4730 if (SvCUR(PL_regex_pad[0])) {
4731 /* Pop off the "packed" IV from the end. */
4732 SV *const repointer_list = PL_regex_pad[0];
4733 const char *p = SvEND(repointer_list) - sizeof(IV);
4734 const IV offset = *((IV*)p);
4736 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4738 SvEND_set(repointer_list, p);
4740 pmop->op_pmoffset = offset;
4741 /* This slot should be free, so assert this: */
4742 assert(PL_regex_pad[offset] == &PL_sv_undef);
4744 SV * const repointer = &PL_sv_undef;
4745 av_push(PL_regex_padav, repointer);
4746 pmop->op_pmoffset = av_tindex(PL_regex_padav);
4747 PL_regex_pad = AvARRAY(PL_regex_padav);
4751 return CHECKOP(type, pmop);
4754 /* Given some sort of match op o, and an expression expr containing a
4755 * pattern, either compile expr into a regex and attach it to o (if it's
4756 * constant), or convert expr into a runtime regcomp op sequence (if it's
4759 * isreg indicates that the pattern is part of a regex construct, eg
4760 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4761 * split "pattern", which aren't. In the former case, expr will be a list
4762 * if the pattern contains more than one term (eg /a$b/) or if it contains
4763 * a replacement, ie s/// or tr///.
4765 * When the pattern has been compiled within a new anon CV (for
4766 * qr/(?{...})/ ), then floor indicates the savestack level just before
4767 * the new sub was created
4771 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4776 I32 repl_has_vars = 0;
4778 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4779 bool is_compiletime;
4782 PERL_ARGS_ASSERT_PMRUNTIME;
4784 /* for s/// and tr///, last element in list is the replacement; pop it */
4786 if (is_trans || o->op_type == OP_SUBST) {
4788 repl = cLISTOPx(expr)->op_last;
4789 kid = cLISTOPx(expr)->op_first;
4790 while (kid->op_sibling != repl)
4791 kid = kid->op_sibling;
4792 kid->op_sibling = NULL;
4793 cLISTOPx(expr)->op_last = kid;
4796 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4799 OP* const oe = expr;
4800 assert(expr->op_type == OP_LIST);
4801 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4802 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4803 expr = cLISTOPx(oe)->op_last;
4804 cLISTOPx(oe)->op_first->op_sibling = NULL;
4805 cLISTOPx(oe)->op_last = NULL;
4808 return pmtrans(o, expr, repl);
4811 /* find whether we have any runtime or code elements;
4812 * at the same time, temporarily set the op_next of each DO block;
4813 * then when we LINKLIST, this will cause the DO blocks to be excluded
4814 * from the op_next chain (and from having LINKLIST recursively
4815 * applied to them). We fix up the DOs specially later */
4819 if (expr->op_type == OP_LIST) {
4821 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4822 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4824 assert(!o->op_next && o->op_sibling);
4825 o->op_next = o->op_sibling;
4827 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4831 else if (expr->op_type != OP_CONST)
4836 /* fix up DO blocks; treat each one as a separate little sub;
4837 * also, mark any arrays as LIST/REF */
4839 if (expr->op_type == OP_LIST) {
4841 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4843 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4844 assert( !(o->op_flags & OPf_WANT));
4845 /* push the array rather than its contents. The regex
4846 * engine will retrieve and join the elements later */
4847 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4851 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4853 o->op_next = NULL; /* undo temporary hack from above */
4856 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4857 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4859 assert(leaveop->op_first->op_type == OP_ENTER);
4860 assert(leaveop->op_first->op_sibling);
4861 o->op_next = leaveop->op_first->op_sibling;
4863 assert(leaveop->op_flags & OPf_KIDS);
4864 assert(leaveop->op_last->op_next == (OP*)leaveop);
4865 leaveop->op_next = NULL; /* stop on last op */
4866 op_null((OP*)leaveop);
4870 OP *scope = cLISTOPo->op_first;
4871 assert(scope->op_type == OP_SCOPE);
4872 assert(scope->op_flags & OPf_KIDS);
4873 scope->op_next = NULL; /* stop on last op */
4876 /* have to peep the DOs individually as we've removed it from
4877 * the op_next chain */
4880 /* runtime finalizes as part of finalizing whole tree */
4884 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4885 assert( !(expr->op_flags & OPf_WANT));
4886 /* push the array rather than its contents. The regex
4887 * engine will retrieve and join the elements later */
4888 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4891 PL_hints |= HINT_BLOCK_SCOPE;
4893 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4895 if (is_compiletime) {
4896 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4897 regexp_engine const *eng = current_re_engine();
4899 if (o->op_flags & OPf_SPECIAL)
4900 rx_flags |= RXf_SPLIT;
4902 if (!has_code || !eng->op_comp) {
4903 /* compile-time simple constant pattern */
4905 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4906 /* whoops! we guessed that a qr// had a code block, but we
4907 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4908 * that isn't required now. Note that we have to be pretty
4909 * confident that nothing used that CV's pad while the
4910 * regex was parsed */
4911 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4912 /* But we know that one op is using this CV's slab. */
4913 cv_forget_slab(PL_compcv);
4915 pm->op_pmflags &= ~PMf_HAS_CV;
4920 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4921 rx_flags, pm->op_pmflags)
4922 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4923 rx_flags, pm->op_pmflags)
4926 op_getmad(expr,(OP*)pm,'e');
4932 /* compile-time pattern that includes literal code blocks */
4933 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4936 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4939 if (pm->op_pmflags & PMf_HAS_CV) {
4941 /* this QR op (and the anon sub we embed it in) is never
4942 * actually executed. It's just a placeholder where we can
4943 * squirrel away expr in op_code_list without the peephole
4944 * optimiser etc processing it for a second time */
4945 OP *qr = newPMOP(OP_QR, 0);
4946 ((PMOP*)qr)->op_code_list = expr;
4948 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4949 SvREFCNT_inc_simple_void(PL_compcv);
4950 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4951 ReANY(re)->qr_anoncv = cv;
4953 /* attach the anon CV to the pad so that
4954 * pad_fixup_inner_anons() can find it */
4955 (void)pad_add_anon(cv, o->op_type);
4956 SvREFCNT_inc_simple_void(cv);
4959 pm->op_code_list = expr;
4964 /* runtime pattern: build chain of regcomp etc ops */
4966 PADOFFSET cv_targ = 0;
4968 reglist = isreg && expr->op_type == OP_LIST;
4973 pm->op_code_list = expr;
4974 /* don't free op_code_list; its ops are embedded elsewhere too */
4975 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4978 if (o->op_flags & OPf_SPECIAL)
4979 pm->op_pmflags |= PMf_SPLIT;
4981 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4982 * to allow its op_next to be pointed past the regcomp and
4983 * preceding stacking ops;
4984 * OP_REGCRESET is there to reset taint before executing the
4986 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4987 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4989 if (pm->op_pmflags & PMf_HAS_CV) {
4990 /* we have a runtime qr with literal code. This means
4991 * that the qr// has been wrapped in a new CV, which
4992 * means that runtime consts, vars etc will have been compiled
4993 * against a new pad. So... we need to execute those ops
4994 * within the environment of the new CV. So wrap them in a call
4995 * to a new anon sub. i.e. for
4999 * we build an anon sub that looks like
5001 * sub { "a", $b, '(?{...})' }
5003 * and call it, passing the returned list to regcomp.
5004 * Or to put it another way, the list of ops that get executed
5008 * ------ -------------------
5009 * pushmark (for regcomp)
5010 * pushmark (for entersub)
5011 * pushmark (for refgen)
5015 * regcreset regcreset
5017 * const("a") const("a")
5019 * const("(?{...})") const("(?{...})")
5024 SvREFCNT_inc_simple_void(PL_compcv);
5025 /* these lines are just an unrolled newANONATTRSUB */
5026 expr = newSVOP(OP_ANONCODE, 0,
5027 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5028 cv_targ = expr->op_targ;
5029 expr = newUNOP(OP_REFGEN, 0, expr);
5031 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
5034 NewOp(1101, rcop, 1, LOGOP);
5035 rcop->op_type = OP_REGCOMP;
5036 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5037 rcop->op_first = scalar(expr);
5038 rcop->op_flags |= OPf_KIDS
5039 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5040 | (reglist ? OPf_STACKED : 0);
5041 rcop->op_private = 0;
5043 rcop->op_targ = cv_targ;
5045 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5046 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5048 /* establish postfix order */
5049 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5051 rcop->op_next = expr;
5052 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5055 rcop->op_next = LINKLIST(expr);
5056 expr->op_next = (OP*)rcop;
5059 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5065 /* If we are looking at s//.../e with a single statement, get past
5066 the implicit do{}. */
5067 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5068 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5069 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
5070 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5071 if (kid->op_type == OP_NULL && kid->op_sibling
5072 && !kid->op_sibling->op_sibling)
5073 curop = kid->op_sibling;
5075 if (curop->op_type == OP_CONST)
5077 else if (( (curop->op_type == OP_RV2SV ||
5078 curop->op_type == OP_RV2AV ||
5079 curop->op_type == OP_RV2HV ||
5080 curop->op_type == OP_RV2GV)
5081 && cUNOPx(curop)->op_first
5082 && cUNOPx(curop)->op_first->op_type == OP_GV )
5083 || curop->op_type == OP_PADSV
5084 || curop->op_type == OP_PADAV
5085 || curop->op_type == OP_PADHV
5086 || curop->op_type == OP_PADANY) {
5094 || !RX_PRELEN(PM_GETRE(pm))
5095 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5097 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5098 op_prepend_elem(o->op_type, scalar(repl), o);
5101 NewOp(1101, rcop, 1, LOGOP);
5102 rcop->op_type = OP_SUBSTCONT;
5103 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5104 rcop->op_first = scalar(repl);
5105 rcop->op_flags |= OPf_KIDS;
5106 rcop->op_private = 1;
5109 /* establish postfix order */
5110 rcop->op_next = LINKLIST(repl);
5111 repl->op_next = (OP*)rcop;
5113 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5114 assert(!(pm->op_pmflags & PMf_ONCE));
5115 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5124 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5126 Constructs, checks, and returns an op of any type that involves an
5127 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5128 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5129 takes ownership of one reference to it.
5135 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5140 PERL_ARGS_ASSERT_NEWSVOP;
5142 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5143 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5144 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5146 NewOp(1101, svop, 1, SVOP);
5147 svop->op_type = (OPCODE)type;
5148 svop->op_ppaddr = PL_ppaddr[type];
5150 svop->op_next = (OP*)svop;
5151 svop->op_flags = (U8)flags;
5152 svop->op_private = (U8)(0 | (flags >> 8));
5153 if (PL_opargs[type] & OA_RETSCALAR)
5155 if (PL_opargs[type] & OA_TARGET)
5156 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5157 return CHECKOP(type, svop);
5163 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5165 Constructs, checks, and returns an op of any type that involves a
5166 reference to a pad element. I<type> is the opcode. I<flags> gives the
5167 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5168 is populated with I<sv>; this function takes ownership of one reference
5171 This function only exists if Perl has been compiled to use ithreads.
5177 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5182 PERL_ARGS_ASSERT_NEWPADOP;
5184 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5185 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5186 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5188 NewOp(1101, padop, 1, PADOP);
5189 padop->op_type = (OPCODE)type;
5190 padop->op_ppaddr = PL_ppaddr[type];
5191 padop->op_padix = pad_alloc(type, SVs_PADTMP);
5192 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5193 PAD_SETSV(padop->op_padix, sv);
5196 padop->op_next = (OP*)padop;
5197 padop->op_flags = (U8)flags;
5198 if (PL_opargs[type] & OA_RETSCALAR)
5200 if (PL_opargs[type] & OA_TARGET)
5201 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5202 return CHECKOP(type, padop);
5205 #endif /* USE_ITHREADS */
5208 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5210 Constructs, checks, and returns an op of any type that involves an
5211 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5212 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5213 reference; calling this function does not transfer ownership of any
5220 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5224 PERL_ARGS_ASSERT_NEWGVOP;
5228 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5230 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5235 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5237 Constructs, checks, and returns an op of any type that involves an
5238 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5239 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5240 must have been allocated using C<PerlMemShared_malloc>; the memory will
5241 be freed when the op is destroyed.
5247 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5250 const bool utf8 = cBOOL(flags & SVf_UTF8);
5255 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5257 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5259 NewOp(1101, pvop, 1, PVOP);
5260 pvop->op_type = (OPCODE)type;
5261 pvop->op_ppaddr = PL_ppaddr[type];
5263 pvop->op_next = (OP*)pvop;
5264 pvop->op_flags = (U8)flags;
5265 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5266 if (PL_opargs[type] & OA_RETSCALAR)
5268 if (PL_opargs[type] & OA_TARGET)
5269 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5270 return CHECKOP(type, pvop);
5278 Perl_package(pTHX_ OP *o)
5281 SV *const sv = cSVOPo->op_sv;
5286 PERL_ARGS_ASSERT_PACKAGE;
5288 SAVEGENERICSV(PL_curstash);
5289 save_item(PL_curstname);
5291 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5293 sv_setsv(PL_curstname, sv);
5295 PL_hints |= HINT_BLOCK_SCOPE;
5296 PL_parser->copline = NOLINE;
5297 PL_parser->expect = XSTATE;
5302 if (!PL_madskills) {
5307 pegop = newOP(OP_NULL,0);
5308 op_getmad(o,pegop,'P');
5314 Perl_package_version( pTHX_ OP *v )
5317 U32 savehints = PL_hints;
5318 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5319 PL_hints &= ~HINT_STRICT_VARS;
5320 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5321 PL_hints = savehints;
5330 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5337 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5339 SV *use_version = NULL;
5341 PERL_ARGS_ASSERT_UTILIZE;
5343 if (idop->op_type != OP_CONST)
5344 Perl_croak(aTHX_ "Module name must be constant");
5347 op_getmad(idop,pegop,'U');
5352 SV * const vesv = ((SVOP*)version)->op_sv;
5355 op_getmad(version,pegop,'V');
5356 if (!arg && !SvNIOKp(vesv)) {
5363 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5364 Perl_croak(aTHX_ "Version number must be a constant number");
5366 /* Make copy of idop so we don't free it twice */
5367 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5369 /* Fake up a method call to VERSION */
5370 meth = newSVpvs_share("VERSION");
5371 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5372 op_append_elem(OP_LIST,
5373 op_prepend_elem(OP_LIST, pack, list(version)),
5374 newSVOP(OP_METHOD_NAMED, 0, meth)));
5378 /* Fake up an import/unimport */
5379 if (arg && arg->op_type == OP_STUB) {
5381 op_getmad(arg,pegop,'S');
5382 imop = arg; /* no import on explicit () */
5384 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5385 imop = NULL; /* use 5.0; */
5387 use_version = ((SVOP*)idop)->op_sv;
5389 idop->op_private |= OPpCONST_NOVER;
5395 op_getmad(arg,pegop,'A');
5397 /* Make copy of idop so we don't free it twice */
5398 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5400 /* Fake up a method call to import/unimport */
5402 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5403 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5404 op_append_elem(OP_LIST,
5405 op_prepend_elem(OP_LIST, pack, list(arg)),
5406 newSVOP(OP_METHOD_NAMED, 0, meth)));
5409 /* Fake up the BEGIN {}, which does its thing immediately. */
5411 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5414 op_append_elem(OP_LINESEQ,
5415 op_append_elem(OP_LINESEQ,
5416 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5417 newSTATEOP(0, NULL, veop)),
5418 newSTATEOP(0, NULL, imop) ));
5422 * feature bundle that corresponds to the required version. */
5423 use_version = sv_2mortal(new_version(use_version));
5424 S_enable_feature_bundle(aTHX_ use_version);
5426 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5427 if (vcmp(use_version,
5428 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5429 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5430 PL_hints |= HINT_STRICT_REFS;
5431 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5432 PL_hints |= HINT_STRICT_SUBS;
5433 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5434 PL_hints |= HINT_STRICT_VARS;
5436 /* otherwise they are off */
5438 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5439 PL_hints &= ~HINT_STRICT_REFS;
5440 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5441 PL_hints &= ~HINT_STRICT_SUBS;
5442 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5443 PL_hints &= ~HINT_STRICT_VARS;
5447 /* The "did you use incorrect case?" warning used to be here.
5448 * The problem is that on case-insensitive filesystems one
5449 * might get false positives for "use" (and "require"):
5450 * "use Strict" or "require CARP" will work. This causes
5451 * portability problems for the script: in case-strict
5452 * filesystems the script will stop working.
5454 * The "incorrect case" warning checked whether "use Foo"
5455 * imported "Foo" to your namespace, but that is wrong, too:
5456 * there is no requirement nor promise in the language that
5457 * a Foo.pm should or would contain anything in package "Foo".
5459 * There is very little Configure-wise that can be done, either:
5460 * the case-sensitivity of the build filesystem of Perl does not
5461 * help in guessing the case-sensitivity of the runtime environment.
5464 PL_hints |= HINT_BLOCK_SCOPE;
5465 PL_parser->copline = NOLINE;
5466 PL_parser->expect = XSTATE;
5467 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5468 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5477 =head1 Embedding Functions
5479 =for apidoc load_module
5481 Loads the module whose name is pointed to by the string part of name.
5482 Note that the actual module name, not its filename, should be given.
5483 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5484 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5485 (or 0 for no flags). ver, if specified
5486 and not NULL, provides version semantics
5487 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5488 arguments can be used to specify arguments to the module's import()
5489 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5490 terminated with a final NULL pointer. Note that this list can only
5491 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5492 Otherwise at least a single NULL pointer to designate the default
5493 import list is required.
5495 The reference count for each specified C<SV*> parameter is decremented.
5500 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5504 PERL_ARGS_ASSERT_LOAD_MODULE;
5506 va_start(args, ver);
5507 vload_module(flags, name, ver, &args);
5511 #ifdef PERL_IMPLICIT_CONTEXT
5513 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5517 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5518 va_start(args, ver);
5519 vload_module(flags, name, ver, &args);
5525 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5529 OP * const modname = newSVOP(OP_CONST, 0, name);
5531 PERL_ARGS_ASSERT_VLOAD_MODULE;
5533 modname->op_private |= OPpCONST_BARE;
5535 veop = newSVOP(OP_CONST, 0, ver);
5539 if (flags & PERL_LOADMOD_NOIMPORT) {
5540 imop = sawparens(newNULLLIST());
5542 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5543 imop = va_arg(*args, OP*);
5548 sv = va_arg(*args, SV*);
5550 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5551 sv = va_arg(*args, SV*);
5555 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5556 * that it has a PL_parser to play with while doing that, and also
5557 * that it doesn't mess with any existing parser, by creating a tmp
5558 * new parser with lex_start(). This won't actually be used for much,
5559 * since pp_require() will create another parser for the real work.
5560 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5563 SAVEVPTR(PL_curcop);
5564 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5565 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5566 veop, modname, imop);
5570 PERL_STATIC_INLINE OP *
5571 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5573 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5574 newLISTOP(OP_LIST, 0, arg,
5575 newUNOP(OP_RV2CV, 0,
5576 newGVOP(OP_GV, 0, gv))));
5580 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5586 PERL_ARGS_ASSERT_DOFILE;
5588 if (!force_builtin && (gv = gv_override("do", 2))) {
5589 doop = S_new_entersubop(aTHX_ gv, term);
5592 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5598 =head1 Optree construction
5600 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5602 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5603 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5604 be set automatically, and, shifted up eight bits, the eight bits of
5605 C<op_private>, except that the bit with value 1 or 2 is automatically
5606 set as required. I<listval> and I<subscript> supply the parameters of
5607 the slice; they are consumed by this function and become part of the
5608 constructed op tree.
5614 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5616 return newBINOP(OP_LSLICE, flags,
5617 list(force_list(subscript)),
5618 list(force_list(listval)) );
5622 S_is_list_assignment(pTHX_ const OP *o)
5630 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5631 o = cUNOPo->op_first;
5633 flags = o->op_flags;
5635 if (type == OP_COND_EXPR) {
5636 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5637 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5642 yyerror("Assignment to both a list and a scalar");
5646 if (type == OP_LIST &&
5647 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5648 o->op_private & OPpLVAL_INTRO)
5651 if (type == OP_LIST || flags & OPf_PARENS ||
5652 type == OP_RV2AV || type == OP_RV2HV ||
5653 type == OP_ASLICE || type == OP_HSLICE ||
5654 type == OP_KVASLICE || type == OP_KVHSLICE)
5657 if (type == OP_PADAV || type == OP_PADHV)
5660 if (type == OP_RV2SV)
5667 Helper function for newASSIGNOP to detection commonality between the
5668 lhs and the rhs. Marks all variables with PL_generation. If it
5669 returns TRUE the assignment must be able to handle common variables.
5671 PERL_STATIC_INLINE bool
5672 S_aassign_common_vars(pTHX_ OP* o)
5675 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5676 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5677 if (curop->op_type == OP_GV) {
5678 GV *gv = cGVOPx_gv(curop);
5680 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5682 GvASSIGN_GENERATION_set(gv, PL_generation);
5684 else if (curop->op_type == OP_PADSV ||
5685 curop->op_type == OP_PADAV ||
5686 curop->op_type == OP_PADHV ||
5687 curop->op_type == OP_PADANY)
5689 if (PAD_COMPNAME_GEN(curop->op_targ)
5690 == (STRLEN)PL_generation)
5692 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5695 else if (curop->op_type == OP_RV2CV)
5697 else if (curop->op_type == OP_RV2SV ||
5698 curop->op_type == OP_RV2AV ||
5699 curop->op_type == OP_RV2HV ||
5700 curop->op_type == OP_RV2GV) {
5701 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5704 else if (curop->op_type == OP_PUSHRE) {
5707 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5708 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5711 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5715 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5717 GvASSIGN_GENERATION_set(gv, PL_generation);
5724 if (curop->op_flags & OPf_KIDS) {
5725 if (aassign_common_vars(curop))
5733 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5735 Constructs, checks, and returns an assignment op. I<left> and I<right>
5736 supply the parameters of the assignment; they are consumed by this
5737 function and become part of the constructed op tree.
5739 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5740 a suitable conditional optree is constructed. If I<optype> is the opcode
5741 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5742 performs the binary operation and assigns the result to the left argument.
5743 Either way, if I<optype> is non-zero then I<flags> has no effect.
5745 If I<optype> is zero, then a plain scalar or list assignment is
5746 constructed. Which type of assignment it is is automatically determined.
5747 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5748 will be set automatically, and, shifted up eight bits, the eight bits
5749 of C<op_private>, except that the bit with value 1 or 2 is automatically
5756 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5762 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5763 return newLOGOP(optype, 0,
5764 op_lvalue(scalar(left), optype),
5765 newUNOP(OP_SASSIGN, 0, scalar(right)));
5768 return newBINOP(optype, OPf_STACKED,
5769 op_lvalue(scalar(left), optype), scalar(right));
5773 if (is_list_assignment(left)) {
5774 static const char no_list_state[] = "Initialization of state variables"
5775 " in list context currently forbidden";
5777 bool maybe_common_vars = TRUE;
5779 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5780 left->op_private &= ~ OPpSLICEWARNING;
5783 left = op_lvalue(left, OP_AASSIGN);
5784 curop = list(force_list(left));
5785 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5786 o->op_private = (U8)(0 | (flags >> 8));
5788 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5790 OP* lop = ((LISTOP*)left)->op_first;
5791 maybe_common_vars = FALSE;
5793 if (lop->op_type == OP_PADSV ||
5794 lop->op_type == OP_PADAV ||
5795 lop->op_type == OP_PADHV ||
5796 lop->op_type == OP_PADANY) {
5797 if (!(lop->op_private & OPpLVAL_INTRO))
5798 maybe_common_vars = TRUE;
5800 if (lop->op_private & OPpPAD_STATE) {
5801 if (left->op_private & OPpLVAL_INTRO) {
5802 /* Each variable in state($a, $b, $c) = ... */
5805 /* Each state variable in
5806 (state $a, my $b, our $c, $d, undef) = ... */
5808 yyerror(no_list_state);
5810 /* Each my variable in
5811 (state $a, my $b, our $c, $d, undef) = ... */
5813 } else if (lop->op_type == OP_UNDEF ||
5814 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5815 /* undef may be interesting in
5816 (state $a, undef, state $c) */
5818 /* Other ops in the list. */
5819 maybe_common_vars = TRUE;
5821 lop = lop->op_sibling;
5824 else if ((left->op_private & OPpLVAL_INTRO)
5825 && ( left->op_type == OP_PADSV
5826 || left->op_type == OP_PADAV
5827 || left->op_type == OP_PADHV
5828 || left->op_type == OP_PADANY))
5830 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5831 if (left->op_private & OPpPAD_STATE) {
5832 /* All single variable list context state assignments, hence
5842 yyerror(no_list_state);
5846 /* PL_generation sorcery:
5847 * an assignment like ($a,$b) = ($c,$d) is easier than
5848 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5849 * To detect whether there are common vars, the global var
5850 * PL_generation is incremented for each assign op we compile.
5851 * Then, while compiling the assign op, we run through all the
5852 * variables on both sides of the assignment, setting a spare slot
5853 * in each of them to PL_generation. If any of them already have
5854 * that value, we know we've got commonality. We could use a
5855 * single bit marker, but then we'd have to make 2 passes, first
5856 * to clear the flag, then to test and set it. To find somewhere
5857 * to store these values, evil chicanery is done with SvUVX().
5860 if (maybe_common_vars) {
5862 if (aassign_common_vars(o))
5863 o->op_private |= OPpASSIGN_COMMON;
5867 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5868 OP* tmpop = ((LISTOP*)right)->op_first;
5869 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5870 PMOP * const pm = (PMOP*)tmpop;
5871 if (left->op_type == OP_RV2AV &&
5872 !(left->op_private & OPpLVAL_INTRO) &&
5873 !(o->op_private & OPpASSIGN_COMMON) )
5875 tmpop = ((UNOP*)left)->op_first;
5876 if (tmpop->op_type == OP_GV
5878 && !pm->op_pmreplrootu.op_pmtargetoff
5880 && !pm->op_pmreplrootu.op_pmtargetgv
5884 pm->op_pmreplrootu.op_pmtargetoff
5885 = cPADOPx(tmpop)->op_padix;
5886 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5888 pm->op_pmreplrootu.op_pmtargetgv
5889 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5890 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5892 tmpop = cUNOPo->op_first; /* to list (nulled) */
5893 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5894 tmpop->op_sibling = NULL; /* don't free split */
5895 right->op_next = tmpop->op_next; /* fix starting loc */
5896 op_free(o); /* blow off assign */
5897 right->op_flags &= ~OPf_WANT;
5898 /* "I don't know and I don't care." */
5903 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5904 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5907 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5908 SV * const sv = *svp;
5909 if (SvIOK(sv) && SvIVX(sv) == 0)
5911 if (right->op_private & OPpSPLIT_IMPLIM) {
5912 /* our own SV, created in ck_split */
5914 sv_setiv(sv, PL_modcount+1);
5917 /* SV may belong to someone else */
5919 *svp = newSViv(PL_modcount+1);
5929 right = newOP(OP_UNDEF, 0);
5930 if (right->op_type == OP_READLINE) {
5931 right->op_flags |= OPf_STACKED;
5932 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5936 o = newBINOP(OP_SASSIGN, flags,
5937 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5943 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5945 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5946 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5947 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5948 If I<label> is non-null, it supplies the name of a label to attach to
5949 the state op; this function takes ownership of the memory pointed at by
5950 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5953 If I<o> is null, the state op is returned. Otherwise the state op is
5954 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5955 is consumed by this function and becomes part of the returned op tree.
5961 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5964 const U32 seq = intro_my();
5965 const U32 utf8 = flags & SVf_UTF8;
5970 NewOp(1101, cop, 1, COP);
5971 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5972 cop->op_type = OP_DBSTATE;
5973 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5976 cop->op_type = OP_NEXTSTATE;
5977 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5979 cop->op_flags = (U8)flags;
5980 CopHINTS_set(cop, PL_hints);
5982 cop->op_private |= NATIVE_HINTS;
5985 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5987 cop->op_next = (OP*)cop;
5990 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5991 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5993 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5995 PL_hints |= HINT_BLOCK_SCOPE;
5996 /* It seems that we need to defer freeing this pointer, as other parts
5997 of the grammar end up wanting to copy it after this op has been
6002 if (PL_parser->preambling != NOLINE) {
6003 CopLINE_set(cop, PL_parser->preambling);
6004 PL_parser->copline = NOLINE;
6006 else if (PL_parser->copline == NOLINE)
6007 CopLINE_set(cop, CopLINE(PL_curcop));
6009 CopLINE_set(cop, PL_parser->copline);
6010 PL_parser->copline = NOLINE;
6013 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6015 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6017 CopSTASH_set(cop, PL_curstash);
6019 if (cop->op_type == OP_DBSTATE) {
6020 /* this line can have a breakpoint - store the cop in IV */
6021 AV *av = CopFILEAVx(PL_curcop);
6023 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6024 if (svp && *svp != &PL_sv_undef ) {
6025 (void)SvIOK_on(*svp);
6026 SvIV_set(*svp, PTR2IV(cop));
6031 if (flags & OPf_SPECIAL)
6033 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6037 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6039 Constructs, checks, and returns a logical (flow control) op. I<type>
6040 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6041 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6042 the eight bits of C<op_private>, except that the bit with value 1 is
6043 automatically set. I<first> supplies the expression controlling the
6044 flow, and I<other> supplies the side (alternate) chain of ops; they are
6045 consumed by this function and become part of the constructed op tree.
6051 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6055 PERL_ARGS_ASSERT_NEWLOGOP;
6057 return new_logop(type, flags, &first, &other);
6061 S_search_const(pTHX_ OP *o)
6063 PERL_ARGS_ASSERT_SEARCH_CONST;
6065 switch (o->op_type) {
6069 if (o->op_flags & OPf_KIDS)
6070 return search_const(cUNOPo->op_first);
6077 if (!(o->op_flags & OPf_KIDS))
6079 kid = cLISTOPo->op_first;
6081 switch (kid->op_type) {
6085 kid = kid->op_sibling;
6088 if (kid != cLISTOPo->op_last)
6094 kid = cLISTOPo->op_last;
6096 return search_const(kid);
6104 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6112 int prepend_not = 0;
6114 PERL_ARGS_ASSERT_NEW_LOGOP;
6119 /* [perl #59802]: Warn about things like "return $a or $b", which
6120 is parsed as "(return $a) or $b" rather than "return ($a or
6121 $b)". NB: This also applies to xor, which is why we do it
6124 switch (first->op_type) {
6128 /* XXX: Perhaps we should emit a stronger warning for these.
6129 Even with the high-precedence operator they don't seem to do
6132 But until we do, fall through here.
6138 /* XXX: Currently we allow people to "shoot themselves in the
6139 foot" by explicitly writing "(return $a) or $b".
6141 Warn unless we are looking at the result from folding or if
6142 the programmer explicitly grouped the operators like this.
6143 The former can occur with e.g.
6145 use constant FEATURE => ( $] >= ... );
6146 sub { not FEATURE and return or do_stuff(); }
6148 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6149 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6150 "Possible precedence issue with control flow operator");
6151 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6157 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6158 return newBINOP(type, flags, scalar(first), scalar(other));
6160 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6162 scalarboolean(first);
6163 /* optimize AND and OR ops that have NOTs as children */
6164 if (first->op_type == OP_NOT
6165 && (first->op_flags & OPf_KIDS)
6166 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6167 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6169 if (type == OP_AND || type == OP_OR) {
6175 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6177 prepend_not = 1; /* prepend a NOT op later */
6181 /* search for a constant op that could let us fold the test */
6182 if ((cstop = search_const(first))) {
6183 if (cstop->op_private & OPpCONST_STRICT)
6184 no_bareword_allowed(cstop);
6185 else if ((cstop->op_private & OPpCONST_BARE))
6186 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6187 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6188 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6189 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6191 if (other->op_type == OP_CONST)
6192 other->op_private |= OPpCONST_SHORTCIRCUIT;
6194 OP *newop = newUNOP(OP_NULL, 0, other);
6195 op_getmad(first, newop, '1');
6196 newop->op_targ = type; /* set "was" field */
6200 if (other->op_type == OP_LEAVE)
6201 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6202 else if (other->op_type == OP_MATCH
6203 || other->op_type == OP_SUBST
6204 || other->op_type == OP_TRANSR
6205 || other->op_type == OP_TRANS)
6206 /* Mark the op as being unbindable with =~ */
6207 other->op_flags |= OPf_SPECIAL;
6209 other->op_folded = 1;
6213 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6214 const OP *o2 = other;
6215 if ( ! (o2->op_type == OP_LIST
6216 && (( o2 = cUNOPx(o2)->op_first))
6217 && o2->op_type == OP_PUSHMARK
6218 && (( o2 = o2->op_sibling)) )
6221 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6222 || o2->op_type == OP_PADHV)
6223 && o2->op_private & OPpLVAL_INTRO
6224 && !(o2->op_private & OPpPAD_STATE))
6226 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6227 "Deprecated use of my() in false conditional");
6231 if (cstop->op_type == OP_CONST)
6232 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6234 first = newUNOP(OP_NULL, 0, first);
6235 op_getmad(other, first, '2');
6236 first->op_targ = type; /* set "was" field */
6243 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6244 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6246 const OP * const k1 = ((UNOP*)first)->op_first;
6247 const OP * const k2 = k1->op_sibling;
6249 switch (first->op_type)
6252 if (k2 && k2->op_type == OP_READLINE
6253 && (k2->op_flags & OPf_STACKED)
6254 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6256 warnop = k2->op_type;
6261 if (k1->op_type == OP_READDIR
6262 || k1->op_type == OP_GLOB
6263 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6264 || k1->op_type == OP_EACH
6265 || k1->op_type == OP_AEACH)
6267 warnop = ((k1->op_type == OP_NULL)
6268 ? (OPCODE)k1->op_targ : k1->op_type);
6273 const line_t oldline = CopLINE(PL_curcop);
6274 /* This ensures that warnings are reported at the first line
6275 of the construction, not the last. */
6276 CopLINE_set(PL_curcop, PL_parser->copline);
6277 Perl_warner(aTHX_ packWARN(WARN_MISC),
6278 "Value of %s%s can be \"0\"; test with defined()",
6280 ((warnop == OP_READLINE || warnop == OP_GLOB)
6281 ? " construct" : "() operator"));
6282 CopLINE_set(PL_curcop, oldline);
6289 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6290 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6292 NewOp(1101, logop, 1, LOGOP);
6294 logop->op_type = (OPCODE)type;
6295 logop->op_ppaddr = PL_ppaddr[type];
6296 logop->op_first = first;
6297 logop->op_flags = (U8)(flags | OPf_KIDS);
6298 logop->op_other = LINKLIST(other);
6299 logop->op_private = (U8)(1 | (flags >> 8));
6301 /* establish postfix order */
6302 logop->op_next = LINKLIST(first);
6303 first->op_next = (OP*)logop;
6304 first->op_sibling = other;
6306 CHECKOP(type,logop);
6308 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6315 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6317 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6318 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6319 will be set automatically, and, shifted up eight bits, the eight bits of
6320 C<op_private>, except that the bit with value 1 is automatically set.
6321 I<first> supplies the expression selecting between the two branches,
6322 and I<trueop> and I<falseop> supply the branches; they are consumed by
6323 this function and become part of the constructed op tree.
6329 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6337 PERL_ARGS_ASSERT_NEWCONDOP;
6340 return newLOGOP(OP_AND, 0, first, trueop);
6342 return newLOGOP(OP_OR, 0, first, falseop);
6344 scalarboolean(first);
6345 if ((cstop = search_const(first))) {
6346 /* Left or right arm of the conditional? */
6347 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6348 OP *live = left ? trueop : falseop;
6349 OP *const dead = left ? falseop : trueop;
6350 if (cstop->op_private & OPpCONST_BARE &&
6351 cstop->op_private & OPpCONST_STRICT) {
6352 no_bareword_allowed(cstop);
6355 /* This is all dead code when PERL_MAD is not defined. */
6356 live = newUNOP(OP_NULL, 0, live);
6357 op_getmad(first, live, 'C');
6358 op_getmad(dead, live, left ? 'e' : 't');
6363 if (live->op_type == OP_LEAVE)
6364 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6365 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6366 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6367 /* Mark the op as being unbindable with =~ */
6368 live->op_flags |= OPf_SPECIAL;
6369 live->op_folded = 1;
6372 NewOp(1101, logop, 1, LOGOP);
6373 logop->op_type = OP_COND_EXPR;
6374 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6375 logop->op_first = first;
6376 logop->op_flags = (U8)(flags | OPf_KIDS);
6377 logop->op_private = (U8)(1 | (flags >> 8));
6378 logop->op_other = LINKLIST(trueop);
6379 logop->op_next = LINKLIST(falseop);
6381 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6384 /* establish postfix order */
6385 start = LINKLIST(first);
6386 first->op_next = (OP*)logop;
6388 first->op_sibling = trueop;
6389 trueop->op_sibling = falseop;
6390 o = newUNOP(OP_NULL, 0, (OP*)logop);
6392 trueop->op_next = falseop->op_next = o;
6399 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6401 Constructs and returns a C<range> op, with subordinate C<flip> and
6402 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6403 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6404 for both the C<flip> and C<range> ops, except that the bit with value
6405 1 is automatically set. I<left> and I<right> supply the expressions
6406 controlling the endpoints of the range; they are consumed by this function
6407 and become part of the constructed op tree.
6413 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6422 PERL_ARGS_ASSERT_NEWRANGE;
6424 NewOp(1101, range, 1, LOGOP);
6426 range->op_type = OP_RANGE;
6427 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6428 range->op_first = left;
6429 range->op_flags = OPf_KIDS;
6430 leftstart = LINKLIST(left);
6431 range->op_other = LINKLIST(right);
6432 range->op_private = (U8)(1 | (flags >> 8));
6434 left->op_sibling = right;
6436 range->op_next = (OP*)range;
6437 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6438 flop = newUNOP(OP_FLOP, 0, flip);
6439 o = newUNOP(OP_NULL, 0, flop);
6441 range->op_next = leftstart;
6443 left->op_next = flip;
6444 right->op_next = flop;
6446 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6447 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6448 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6449 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6451 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6452 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6454 /* check barewords before they might be optimized aways */
6455 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6456 no_bareword_allowed(left);
6457 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6458 no_bareword_allowed(right);
6461 if (!flip->op_private || !flop->op_private)
6462 LINKLIST(o); /* blow off optimizer unless constant */
6468 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6470 Constructs, checks, and returns an op tree expressing a loop. This is
6471 only a loop in the control flow through the op tree; it does not have
6472 the heavyweight loop structure that allows exiting the loop by C<last>
6473 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6474 top-level op, except that some bits will be set automatically as required.
6475 I<expr> supplies the expression controlling loop iteration, and I<block>
6476 supplies the body of the loop; they are consumed by this function and
6477 become part of the constructed op tree. I<debuggable> is currently
6478 unused and should always be 1.
6484 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6489 const bool once = block && block->op_flags & OPf_SPECIAL &&
6490 block->op_type == OP_NULL;
6492 PERL_UNUSED_ARG(debuggable);
6496 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6497 || ( expr->op_type == OP_NOT
6498 && cUNOPx(expr)->op_first->op_type == OP_CONST
6499 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6502 /* Return the block now, so that S_new_logop does not try to
6504 return block; /* do {} while 0 does once */
6505 if (expr->op_type == OP_READLINE
6506 || expr->op_type == OP_READDIR
6507 || expr->op_type == OP_GLOB
6508 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6509 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6510 expr = newUNOP(OP_DEFINED, 0,
6511 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6512 } else if (expr->op_flags & OPf_KIDS) {
6513 const OP * const k1 = ((UNOP*)expr)->op_first;
6514 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6515 switch (expr->op_type) {
6517 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6518 && (k2->op_flags & OPf_STACKED)
6519 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6520 expr = newUNOP(OP_DEFINED, 0, expr);
6524 if (k1 && (k1->op_type == OP_READDIR
6525 || k1->op_type == OP_GLOB
6526 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6527 || k1->op_type == OP_EACH
6528 || k1->op_type == OP_AEACH))
6529 expr = newUNOP(OP_DEFINED, 0, expr);
6535 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6536 * op, in listop. This is wrong. [perl #27024] */
6538 block = newOP(OP_NULL, 0);
6539 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6540 o = new_logop(OP_AND, 0, &expr, &listop);
6547 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6549 if (once && o != listop)
6551 assert(cUNOPo->op_first->op_type == OP_AND
6552 || cUNOPo->op_first->op_type == OP_OR);
6553 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6557 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6559 o->op_flags |= flags;
6561 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6566 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6568 Constructs, checks, and returns an op tree expressing a C<while> loop.
6569 This is a heavyweight loop, with structure that allows exiting the loop
6570 by C<last> and suchlike.
6572 I<loop> is an optional preconstructed C<enterloop> op to use in the
6573 loop; if it is null then a suitable op will be constructed automatically.
6574 I<expr> supplies the loop's controlling expression. I<block> supplies the
6575 main body of the loop, and I<cont> optionally supplies a C<continue> block
6576 that operates as a second half of the body. All of these optree inputs
6577 are consumed by this function and become part of the constructed op tree.
6579 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6580 op and, shifted up eight bits, the eight bits of C<op_private> for
6581 the C<leaveloop> op, except that (in both cases) some bits will be set
6582 automatically. I<debuggable> is currently unused and should always be 1.
6583 I<has_my> can be supplied as true to force the
6584 loop body to be enclosed in its own scope.
6590 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6591 OP *expr, OP *block, OP *cont, I32 has_my)
6600 PERL_UNUSED_ARG(debuggable);
6603 if (expr->op_type == OP_READLINE
6604 || expr->op_type == OP_READDIR
6605 || expr->op_type == OP_GLOB
6606 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6607 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6608 expr = newUNOP(OP_DEFINED, 0,
6609 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6610 } else if (expr->op_flags & OPf_KIDS) {
6611 const OP * const k1 = ((UNOP*)expr)->op_first;
6612 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6613 switch (expr->op_type) {
6615 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6616 && (k2->op_flags & OPf_STACKED)
6617 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6618 expr = newUNOP(OP_DEFINED, 0, expr);
6622 if (k1 && (k1->op_type == OP_READDIR
6623 || k1->op_type == OP_GLOB
6624 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6625 || k1->op_type == OP_EACH
6626 || k1->op_type == OP_AEACH))
6627 expr = newUNOP(OP_DEFINED, 0, expr);
6634 block = newOP(OP_NULL, 0);
6635 else if (cont || has_my) {
6636 block = op_scope(block);
6640 next = LINKLIST(cont);
6643 OP * const unstack = newOP(OP_UNSTACK, 0);
6646 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6650 listop = op_append_list(OP_LINESEQ, block, cont);
6652 redo = LINKLIST(listop);
6656 o = new_logop(OP_AND, 0, &expr, &listop);
6657 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6659 return expr; /* listop already freed by new_logop */
6662 ((LISTOP*)listop)->op_last->op_next =
6663 (o == listop ? redo : LINKLIST(o));
6669 NewOp(1101,loop,1,LOOP);
6670 loop->op_type = OP_ENTERLOOP;
6671 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6672 loop->op_private = 0;
6673 loop->op_next = (OP*)loop;
6676 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6678 loop->op_redoop = redo;
6679 loop->op_lastop = o;
6680 o->op_private |= loopflags;
6683 loop->op_nextop = next;
6685 loop->op_nextop = o;
6687 o->op_flags |= flags;
6688 o->op_private |= (flags >> 8);
6693 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6695 Constructs, checks, and returns an op tree expressing a C<foreach>
6696 loop (iteration through a list of values). This is a heavyweight loop,
6697 with structure that allows exiting the loop by C<last> and suchlike.
6699 I<sv> optionally supplies the variable that will be aliased to each
6700 item in turn; if null, it defaults to C<$_> (either lexical or global).
6701 I<expr> supplies the list of values to iterate over. I<block> supplies
6702 the main body of the loop, and I<cont> optionally supplies a C<continue>
6703 block that operates as a second half of the body. All of these optree
6704 inputs are consumed by this function and become part of the constructed
6707 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6708 op and, shifted up eight bits, the eight bits of C<op_private> for
6709 the C<leaveloop> op, except that (in both cases) some bits will be set
6716 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6721 PADOFFSET padoff = 0;
6726 PERL_ARGS_ASSERT_NEWFOROP;
6729 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6730 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6731 sv->op_type = OP_RV2GV;
6732 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6734 /* The op_type check is needed to prevent a possible segfault
6735 * if the loop variable is undeclared and 'strict vars' is in
6736 * effect. This is illegal but is nonetheless parsed, so we
6737 * may reach this point with an OP_CONST where we're expecting
6740 if (cUNOPx(sv)->op_first->op_type == OP_GV
6741 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6742 iterpflags |= OPpITER_DEF;
6744 else if (sv->op_type == OP_PADSV) { /* private variable */
6745 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6746 padoff = sv->op_targ;
6756 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6758 SV *const namesv = PAD_COMPNAME_SV(padoff);
6760 const char *const name = SvPV_const(namesv, len);
6762 if (len == 2 && name[0] == '$' && name[1] == '_')
6763 iterpflags |= OPpITER_DEF;
6767 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6768 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6769 sv = newGVOP(OP_GV, 0, PL_defgv);
6774 iterpflags |= OPpITER_DEF;
6776 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6777 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6778 iterflags |= OPf_STACKED;
6780 else if (expr->op_type == OP_NULL &&
6781 (expr->op_flags & OPf_KIDS) &&
6782 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6784 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6785 * set the STACKED flag to indicate that these values are to be
6786 * treated as min/max values by 'pp_enteriter'.
6788 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6789 LOGOP* const range = (LOGOP*) flip->op_first;
6790 OP* const left = range->op_first;
6791 OP* const right = left->op_sibling;
6794 range->op_flags &= ~OPf_KIDS;
6795 range->op_first = NULL;
6797 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6798 listop->op_first->op_next = range->op_next;
6799 left->op_next = range->op_other;
6800 right->op_next = (OP*)listop;
6801 listop->op_next = listop->op_first;
6804 op_getmad(expr,(OP*)listop,'O');
6808 expr = (OP*)(listop);
6810 iterflags |= OPf_STACKED;
6813 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6816 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6817 op_append_elem(OP_LIST, expr, scalar(sv))));
6818 assert(!loop->op_next);
6819 /* for my $x () sets OPpLVAL_INTRO;
6820 * for our $x () sets OPpOUR_INTRO */
6821 loop->op_private = (U8)iterpflags;
6822 if (loop->op_slabbed
6823 && DIFF(loop, OpSLOT(loop)->opslot_next)
6824 < SIZE_TO_PSIZE(sizeof(LOOP)))
6827 NewOp(1234,tmp,1,LOOP);
6828 Copy(loop,tmp,1,LISTOP);
6829 S_op_destroy(aTHX_ (OP*)loop);
6832 else if (!loop->op_slabbed)
6833 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6834 loop->op_targ = padoff;
6835 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6837 op_getmad(madsv, (OP*)loop, 'v');
6842 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6844 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6845 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6846 determining the target of the op; it is consumed by this function and
6847 becomes part of the constructed op tree.
6853 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6858 PERL_ARGS_ASSERT_NEWLOOPEX;
6860 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6862 if (type != OP_GOTO) {
6863 /* "last()" means "last" */
6864 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6865 o = newOP(type, OPf_SPECIAL);
6869 /* Check whether it's going to be a goto &function */
6870 if (label->op_type == OP_ENTERSUB
6871 && !(label->op_flags & OPf_STACKED))
6872 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6875 /* Check for a constant argument */
6876 if (label->op_type == OP_CONST) {
6877 SV * const sv = ((SVOP *)label)->op_sv;
6879 const char *s = SvPV_const(sv,l);
6880 if (l == strlen(s)) {
6882 SvUTF8(((SVOP*)label)->op_sv),
6884 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6888 /* If we have already created an op, we do not need the label. */
6891 op_getmad(label,o,'L');
6895 else o = newUNOP(type, OPf_STACKED, label);
6897 PL_hints |= HINT_BLOCK_SCOPE;
6901 /* if the condition is a literal array or hash
6902 (or @{ ... } etc), make a reference to it.
6905 S_ref_array_or_hash(pTHX_ OP *cond)
6908 && (cond->op_type == OP_RV2AV
6909 || cond->op_type == OP_PADAV
6910 || cond->op_type == OP_RV2HV
6911 || cond->op_type == OP_PADHV))
6913 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6916 && (cond->op_type == OP_ASLICE
6917 || cond->op_type == OP_KVASLICE
6918 || cond->op_type == OP_HSLICE
6919 || cond->op_type == OP_KVHSLICE)) {
6921 /* anonlist now needs a list from this op, was previously used in
6923 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6924 cond->op_flags |= OPf_WANT_LIST;
6926 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6933 /* These construct the optree fragments representing given()
6936 entergiven and enterwhen are LOGOPs; the op_other pointer
6937 points up to the associated leave op. We need this so we
6938 can put it in the context and make break/continue work.
6939 (Also, of course, pp_enterwhen will jump straight to
6940 op_other if the match fails.)
6944 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6945 I32 enter_opcode, I32 leave_opcode,
6946 PADOFFSET entertarg)
6952 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6954 NewOp(1101, enterop, 1, LOGOP);
6955 enterop->op_type = (Optype)enter_opcode;
6956 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6957 enterop->op_flags = (U8) OPf_KIDS;
6958 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6959 enterop->op_private = 0;
6961 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6964 enterop->op_first = scalar(cond);
6965 cond->op_sibling = block;
6967 o->op_next = LINKLIST(cond);
6968 cond->op_next = (OP *) enterop;
6971 /* This is a default {} block */
6972 enterop->op_first = block;
6973 enterop->op_flags |= OPf_SPECIAL;
6974 o ->op_flags |= OPf_SPECIAL;
6976 o->op_next = (OP *) enterop;
6979 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6980 entergiven and enterwhen both
6983 enterop->op_next = LINKLIST(block);
6984 block->op_next = enterop->op_other = o;
6989 /* Does this look like a boolean operation? For these purposes
6990 a boolean operation is:
6991 - a subroutine call [*]
6992 - a logical connective
6993 - a comparison operator
6994 - a filetest operator, with the exception of -s -M -A -C
6995 - defined(), exists() or eof()
6996 - /$re/ or $foo =~ /$re/
6998 [*] possibly surprising
7001 S_looks_like_bool(pTHX_ const OP *o)
7005 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7007 switch(o->op_type) {
7010 return looks_like_bool(cLOGOPo->op_first);
7014 looks_like_bool(cLOGOPo->op_first)
7015 && looks_like_bool(cLOGOPo->op_first->op_sibling));
7020 o->op_flags & OPf_KIDS
7021 && looks_like_bool(cUNOPo->op_first));
7025 case OP_NOT: case OP_XOR:
7027 case OP_EQ: case OP_NE: case OP_LT:
7028 case OP_GT: case OP_LE: case OP_GE:
7030 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7031 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7033 case OP_SEQ: case OP_SNE: case OP_SLT:
7034 case OP_SGT: case OP_SLE: case OP_SGE:
7038 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7039 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7040 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7041 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7042 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7043 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7044 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7045 case OP_FTTEXT: case OP_FTBINARY:
7047 case OP_DEFINED: case OP_EXISTS:
7048 case OP_MATCH: case OP_EOF:
7055 /* Detect comparisons that have been optimized away */
7056 if (cSVOPo->op_sv == &PL_sv_yes
7057 || cSVOPo->op_sv == &PL_sv_no)
7070 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7072 Constructs, checks, and returns an op tree expressing a C<given> block.
7073 I<cond> supplies the expression that will be locally assigned to a lexical
7074 variable, and I<block> supplies the body of the C<given> construct; they
7075 are consumed by this function and become part of the constructed op tree.
7076 I<defsv_off> is the pad offset of the scalar lexical variable that will
7077 be affected. If it is 0, the global $_ will be used.
7083 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7086 PERL_ARGS_ASSERT_NEWGIVENOP;
7087 return newGIVWHENOP(
7088 ref_array_or_hash(cond),
7090 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7095 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7097 Constructs, checks, and returns an op tree expressing a C<when> block.
7098 I<cond> supplies the test expression, and I<block> supplies the block
7099 that will be executed if the test evaluates to true; they are consumed
7100 by this function and become part of the constructed op tree. I<cond>
7101 will be interpreted DWIMically, often as a comparison against C<$_>,
7102 and may be null to generate a C<default> block.
7108 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7110 const bool cond_llb = (!cond || looks_like_bool(cond));
7113 PERL_ARGS_ASSERT_NEWWHENOP;
7118 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7120 scalar(ref_array_or_hash(cond)));
7123 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7127 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7128 const STRLEN len, const U32 flags)
7130 SV *name = NULL, *msg;
7131 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7132 STRLEN clen = CvPROTOLEN(cv), plen = len;
7134 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7136 if (p == NULL && cvp == NULL)
7139 if (!ckWARN_d(WARN_PROTOTYPE))
7143 p = S_strip_spaces(aTHX_ p, &plen);
7144 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7145 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7146 if (plen == clen && memEQ(cvp, p, plen))
7149 if (flags & SVf_UTF8) {
7150 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7154 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7160 msg = sv_newmortal();
7165 gv_efullname3(name = sv_newmortal(), gv, NULL);
7166 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7167 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7168 else name = (SV *)gv;
7170 sv_setpvs(msg, "Prototype mismatch:");
7172 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7174 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7175 UTF8fARG(SvUTF8(cv),clen,cvp)
7178 sv_catpvs(msg, ": none");
7179 sv_catpvs(msg, " vs ");
7181 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7183 sv_catpvs(msg, "none");
7184 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7187 static void const_sv_xsub(pTHX_ CV* cv);
7188 static void const_av_xsub(pTHX_ CV* cv);
7192 =head1 Optree Manipulation Functions
7194 =for apidoc cv_const_sv
7196 If C<cv> is a constant sub eligible for inlining, returns the constant
7197 value returned by the sub. Otherwise, returns NULL.
7199 Constant subs can be created with C<newCONSTSUB> or as described in
7200 L<perlsub/"Constant Functions">.
7205 Perl_cv_const_sv(pTHX_ const CV *const cv)
7208 PERL_UNUSED_CONTEXT;
7211 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7213 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7214 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7219 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7221 PERL_UNUSED_CONTEXT;
7224 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7225 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7228 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7232 Perl_op_const_sv(pTHX_ const OP *o)
7243 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7244 o = cLISTOPo->op_first->op_sibling;
7246 for (; o; o = o->op_next) {
7247 const OPCODE type = o->op_type;
7249 if (sv && o->op_next == o)
7251 if (o->op_next != o) {
7252 if (type == OP_NEXTSTATE
7253 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7254 || type == OP_PUSHMARK)
7256 if (type == OP_DBSTATE)
7259 if (type == OP_LEAVESUB || type == OP_RETURN)
7263 if (type == OP_CONST && cSVOPo->op_sv)
7273 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7274 PADNAME * const name, SV ** const const_svp)
7281 || block->op_type == OP_NULL
7284 if (CvFLAGS(PL_compcv)) {
7285 /* might have had built-in attrs applied */
7286 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7287 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7288 && ckWARN(WARN_MISC))
7290 /* protect against fatal warnings leaking compcv */
7291 SAVEFREESV(PL_compcv);
7292 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7293 SvREFCNT_inc_simple_void_NN(PL_compcv);
7296 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7297 & ~(CVf_LVALUE * pureperl));
7302 /* redundant check for speed: */
7303 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7304 const line_t oldline = CopLINE(PL_curcop);
7307 : sv_2mortal(newSVpvn_utf8(
7308 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7310 if (PL_parser && PL_parser->copline != NOLINE)
7311 /* This ensures that warnings are reported at the first
7312 line of a redefinition, not the last. */
7313 CopLINE_set(PL_curcop, PL_parser->copline);
7314 /* protect against fatal warnings leaking compcv */
7315 SAVEFREESV(PL_compcv);
7316 report_redefined_cv(namesv, cv, const_svp);
7317 SvREFCNT_inc_simple_void_NN(PL_compcv);
7318 CopLINE_set(PL_curcop, oldline);
7321 if (!PL_minus_c) /* keep old one around for madskills */
7324 /* (PL_madskills unset in used file.) */
7331 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7337 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7340 CV *compcv = PL_compcv;
7343 PADOFFSET pax = o->op_targ;
7344 CV *outcv = CvOUTSIDE(PL_compcv);
7347 bool reusable = FALSE;
7349 PERL_ARGS_ASSERT_NEWMYSUB;
7351 /* Find the pad slot for storing the new sub.
7352 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7353 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7354 ing sub. And then we need to dig deeper if this is a lexical from
7356 my sub foo; sub { sub foo { } }
7359 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7360 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7361 pax = PARENT_PAD_INDEX(name);
7362 outcv = CvOUTSIDE(outcv);
7367 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7368 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7369 spot = (CV **)svspot;
7371 if (!(PL_parser && PL_parser->error_count))
7372 move_proto_attr(&proto, &attrs, (GV *)name);
7375 assert(proto->op_type == OP_CONST);
7376 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7377 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7382 if (!PL_madskills) {
7389 if (PL_parser && PL_parser->error_count) {
7391 SvREFCNT_dec(PL_compcv);
7396 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7398 svspot = (SV **)(spot = &clonee);
7400 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7404 SvUPGRADE(name, SVt_PVMG);
7405 mg = mg_find(name, PERL_MAGIC_proto);
7406 assert (SvTYPE(*spot) == SVt_PVCV);
7408 hek = CvNAME_HEK(*spot);
7410 CvNAME_HEK_set(*spot, hek =
7413 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7419 cv = (CV *)mg->mg_obj;
7422 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7423 mg = mg_find(name, PERL_MAGIC_proto);
7425 spot = (CV **)(svspot = &mg->mg_obj);
7428 if (!block || !ps || *ps || attrs
7429 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7431 || block->op_type == OP_NULL
7436 const_sv = op_const_sv(block);
7439 const bool exists = CvROOT(cv) || CvXSUB(cv);
7441 /* if the subroutine doesn't exist and wasn't pre-declared
7442 * with a prototype, assume it will be AUTOLOADed,
7443 * skipping the prototype check
7445 if (exists || SvPOK(cv))
7446 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7447 /* already defined? */
7449 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7452 if (attrs) goto attrs;
7453 /* just a "sub foo;" when &foo is already defined */
7458 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7464 SvREFCNT_inc_simple_void_NN(const_sv);
7465 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7467 assert(!CvROOT(cv) && !CvCONST(cv));
7471 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7472 CvFILE_set_from_cop(cv, PL_curcop);
7473 CvSTASH_set(cv, PL_curstash);
7476 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7477 CvXSUBANY(cv).any_ptr = const_sv;
7478 CvXSUB(cv) = const_sv_xsub;
7484 SvREFCNT_dec(compcv);
7488 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7489 determine whether this sub definition is in the same scope as its
7490 declaration. If this sub definition is inside an inner named pack-
7491 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7492 the package sub. So check PadnameOUTER(name) too.
7494 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7495 assert(!CvWEAKOUTSIDE(compcv));
7496 SvREFCNT_dec(CvOUTSIDE(compcv));
7497 CvWEAKOUTSIDE_on(compcv);
7499 /* XXX else do we have a circular reference? */
7500 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7501 /* transfer PL_compcv to cv */
7504 && block->op_type != OP_NULL
7507 cv_flags_t preserved_flags =
7508 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7509 PADLIST *const temp_padl = CvPADLIST(cv);
7510 CV *const temp_cv = CvOUTSIDE(cv);
7511 const cv_flags_t other_flags =
7512 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7513 OP * const cvstart = CvSTART(cv);
7517 CvFLAGS(compcv) | preserved_flags;
7518 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7519 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7520 CvPADLIST(cv) = CvPADLIST(compcv);
7521 CvOUTSIDE(compcv) = temp_cv;
7522 CvPADLIST(compcv) = temp_padl;
7523 CvSTART(cv) = CvSTART(compcv);
7524 CvSTART(compcv) = cvstart;
7525 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7526 CvFLAGS(compcv) |= other_flags;
7528 if (CvFILE(cv) && CvDYNFILE(cv)) {
7529 Safefree(CvFILE(cv));
7532 /* inner references to compcv must be fixed up ... */
7533 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7534 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7535 ++PL_sub_generation;
7538 /* Might have had built-in attributes applied -- propagate them. */
7539 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7541 /* ... before we throw it away */
7542 SvREFCNT_dec(compcv);
7543 PL_compcv = compcv = cv;
7550 if (!CvNAME_HEK(cv)) {
7553 ? share_hek_hek(hek)
7554 : share_hek(PadnamePV(name)+1,
7555 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7559 if (const_sv) goto clone;
7561 CvFILE_set_from_cop(cv, PL_curcop);
7562 CvSTASH_set(cv, PL_curstash);
7565 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7566 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7573 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7574 the debugger could be able to set a breakpoint in, so signal to
7575 pp_entereval that it should not throw away any saved lines at scope
7578 PL_breakable_sub_gen++;
7579 /* This makes sub {}; work as expected. */
7580 if (block->op_type == OP_STUB) {
7581 OP* const newblock = newSTATEOP(0, NULL, 0);
7583 op_getmad(block,newblock,'B');
7589 CvROOT(cv) = CvLVALUE(cv)
7590 ? newUNOP(OP_LEAVESUBLV, 0,
7591 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7592 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7593 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7594 OpREFCNT_set(CvROOT(cv), 1);
7595 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7596 itself has a refcount. */
7598 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7599 CvSTART(cv) = LINKLIST(CvROOT(cv));
7600 CvROOT(cv)->op_next = 0;
7601 CALL_PEEP(CvSTART(cv));
7602 finalize_optree(CvROOT(cv));
7604 /* now that optimizer has done its work, adjust pad values */
7606 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7610 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7611 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7615 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7616 SV * const tmpstr = sv_newmortal();
7617 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7618 GV_ADDMULTI, SVt_PVHV);
7620 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7623 (long)CopLINE(PL_curcop));
7624 if (HvNAME_HEK(PL_curstash)) {
7625 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7626 sv_catpvs(tmpstr, "::");
7628 else sv_setpvs(tmpstr, "__ANON__::");
7629 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7630 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7631 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7632 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7633 hv = GvHVn(db_postponed);
7634 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7635 CV * const pcv = GvCV(db_postponed);
7641 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7649 assert(CvDEPTH(outcv));
7651 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7652 if (reusable) cv_clone_into(clonee, *spot);
7653 else *spot = cv_clone(clonee);
7654 SvREFCNT_dec_NN(clonee);
7658 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7659 PADOFFSET depth = CvDEPTH(outcv);
7662 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7664 *svspot = SvREFCNT_inc_simple_NN(cv);
7665 SvREFCNT_dec(oldcv);
7671 PL_parser->copline = NOLINE;
7679 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7680 OP *block, bool o_is_gv)
7685 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7689 const bool ec = PL_parser && PL_parser->error_count;
7690 /* If the subroutine has no body, no attributes, and no builtin attributes
7691 then it's just a sub declaration, and we may be able to get away with
7692 storing with a placeholder scalar in the symbol table, rather than a
7693 full GV and CV. If anything is present then it will take a full CV to
7695 const I32 gv_fetch_flags
7696 = ec ? GV_NOADD_NOINIT :
7697 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7699 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7701 const char * const name =
7702 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7704 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7705 #ifdef PERL_DEBUG_READONLY_OPS
7706 OPSLAB *slab = NULL;
7714 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7716 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7717 SV * const sv = sv_newmortal();
7718 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7719 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7720 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7721 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7723 } else if (PL_curstash) {
7724 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7727 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7732 move_proto_attr(&proto, &attrs, gv);
7735 assert(proto->op_type == OP_CONST);
7736 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7737 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7742 if (!PL_madskills) {
7753 if (name) SvREFCNT_dec(PL_compcv);
7754 else cv = PL_compcv;
7756 if (name && block) {
7757 const char *s = strrchr(name, ':');
7759 if (strEQ(s, "BEGIN")) {
7760 if (PL_in_eval & EVAL_KEEPERR)
7761 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7763 SV * const errsv = ERRSV;
7764 /* force display of errors found but not reported */
7765 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7766 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7773 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7774 maximum a prototype before. */
7775 if (SvTYPE(gv) > SVt_NULL) {
7776 cv_ckproto_len_flags((const CV *)gv,
7777 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7781 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7782 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7785 sv_setiv(MUTABLE_SV(gv), -1);
7787 SvREFCNT_dec(PL_compcv);
7788 cv = PL_compcv = NULL;
7792 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7794 if (!block || !ps || *ps || attrs
7795 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7797 || block->op_type == OP_NULL
7802 const_sv = op_const_sv(block);
7805 const bool exists = CvROOT(cv) || CvXSUB(cv);
7807 /* if the subroutine doesn't exist and wasn't pre-declared
7808 * with a prototype, assume it will be AUTOLOADed,
7809 * skipping the prototype check
7811 if (exists || SvPOK(cv))
7812 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7813 /* already defined (or promised)? */
7814 if (exists || GvASSUMECV(gv)) {
7815 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7818 if (attrs) goto attrs;
7819 /* just a "sub foo;" when &foo is already defined */
7820 SAVEFREESV(PL_compcv);
7826 SvREFCNT_inc_simple_void_NN(const_sv);
7827 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7829 assert(!CvROOT(cv) && !CvCONST(cv));
7831 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7832 CvXSUBANY(cv).any_ptr = const_sv;
7833 CvXSUB(cv) = const_sv_xsub;
7839 cv = newCONSTSUB_flags(
7840 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7847 SvREFCNT_dec(PL_compcv);
7851 if (cv) { /* must reuse cv if autoloaded */
7852 /* transfer PL_compcv to cv */
7855 && block->op_type != OP_NULL
7858 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7859 PADLIST *const temp_av = CvPADLIST(cv);
7860 CV *const temp_cv = CvOUTSIDE(cv);
7861 const cv_flags_t other_flags =
7862 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7863 OP * const cvstart = CvSTART(cv);
7866 assert(!CvCVGV_RC(cv));
7867 assert(CvGV(cv) == gv);
7870 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7871 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7872 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7873 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7874 CvOUTSIDE(PL_compcv) = temp_cv;
7875 CvPADLIST(PL_compcv) = temp_av;
7876 CvSTART(cv) = CvSTART(PL_compcv);
7877 CvSTART(PL_compcv) = cvstart;
7878 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7879 CvFLAGS(PL_compcv) |= other_flags;
7881 if (CvFILE(cv) && CvDYNFILE(cv)) {
7882 Safefree(CvFILE(cv));
7884 CvFILE_set_from_cop(cv, PL_curcop);
7885 CvSTASH_set(cv, PL_curstash);
7887 /* inner references to PL_compcv must be fixed up ... */
7888 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7889 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7890 ++PL_sub_generation;
7893 /* Might have had built-in attributes applied -- propagate them. */
7894 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7896 /* ... before we throw it away */
7897 SvREFCNT_dec(PL_compcv);
7905 if (HvENAME_HEK(GvSTASH(gv)))
7906 /* sub Foo::bar { (shift)+1 } */
7907 gv_method_changed(gv);
7912 CvFILE_set_from_cop(cv, PL_curcop);
7913 CvSTASH_set(cv, PL_curstash);
7917 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7918 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7925 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7926 the debugger could be able to set a breakpoint in, so signal to
7927 pp_entereval that it should not throw away any saved lines at scope
7930 PL_breakable_sub_gen++;
7931 /* This makes sub {}; work as expected. */
7932 if (block->op_type == OP_STUB) {
7933 OP* const newblock = newSTATEOP(0, NULL, 0);
7935 op_getmad(block,newblock,'B');
7941 CvROOT(cv) = CvLVALUE(cv)
7942 ? newUNOP(OP_LEAVESUBLV, 0,
7943 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7944 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7945 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7946 OpREFCNT_set(CvROOT(cv), 1);
7947 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7948 itself has a refcount. */
7950 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7951 #ifdef PERL_DEBUG_READONLY_OPS
7952 slab = (OPSLAB *)CvSTART(cv);
7954 CvSTART(cv) = LINKLIST(CvROOT(cv));
7955 CvROOT(cv)->op_next = 0;
7956 CALL_PEEP(CvSTART(cv));
7957 finalize_optree(CvROOT(cv));
7959 /* now that optimizer has done its work, adjust pad values */
7961 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7965 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7966 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7967 if (!name) SAVEFREESV(cv);
7968 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7969 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7972 if (block && has_name) {
7973 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7974 SV * const tmpstr = sv_newmortal();
7975 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7976 GV_ADDMULTI, SVt_PVHV);
7978 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7981 (long)CopLINE(PL_curcop));
7982 gv_efullname3(tmpstr, gv, NULL);
7983 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7984 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7985 hv = GvHVn(db_postponed);
7986 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7987 CV * const pcv = GvCV(db_postponed);
7993 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7998 if (name && ! (PL_parser && PL_parser->error_count))
7999 process_special_blocks(floor, name, gv, cv);
8004 PL_parser->copline = NOLINE;
8006 #ifdef PERL_DEBUG_READONLY_OPS
8007 /* Watch out for BEGIN blocks */
8008 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
8014 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8018 const char *const colon = strrchr(fullname,':');
8019 const char *const name = colon ? colon + 1 : fullname;
8021 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8024 if (strEQ(name, "BEGIN")) {
8025 const I32 oldscope = PL_scopestack_ix;
8027 if (floor) LEAVE_SCOPE(floor);
8029 PUSHSTACKi(PERLSI_REQUIRE);
8030 SAVECOPFILE(&PL_compiling);
8031 SAVECOPLINE(&PL_compiling);
8032 SAVEVPTR(PL_curcop);
8034 DEBUG_x( dump_sub(gv) );
8035 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8036 GvCV_set(gv,0); /* cv has been hijacked */
8037 call_list(oldscope, PL_beginav);
8046 if strEQ(name, "END") {
8047 DEBUG_x( dump_sub(gv) );
8048 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8051 } else if (*name == 'U') {
8052 if (strEQ(name, "UNITCHECK")) {
8053 /* It's never too late to run a unitcheck block */
8054 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8058 } else if (*name == 'C') {
8059 if (strEQ(name, "CHECK")) {
8061 /* diag_listed_as: Too late to run %s block */
8062 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8063 "Too late to run CHECK block");
8064 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8068 } else if (*name == 'I') {
8069 if (strEQ(name, "INIT")) {
8071 /* diag_listed_as: Too late to run %s block */
8072 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8073 "Too late to run INIT block");
8074 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8080 DEBUG_x( dump_sub(gv) );
8081 GvCV_set(gv,0); /* cv has been hijacked */
8086 =for apidoc newCONSTSUB
8088 See L</newCONSTSUB_flags>.
8094 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8096 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8100 =for apidoc newCONSTSUB_flags
8102 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8103 eligible for inlining at compile-time.
8105 Currently, the only useful value for C<flags> is SVf_UTF8.
8107 The newly created subroutine takes ownership of a reference to the passed in
8110 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8111 which won't be called if used as a destructor, but will suppress the overhead
8112 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8119 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8124 const char *const file = CopFILE(PL_curcop);
8128 if (IN_PERL_RUNTIME) {
8129 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8130 * an op shared between threads. Use a non-shared COP for our
8132 SAVEVPTR(PL_curcop);
8133 SAVECOMPILEWARNINGS();
8134 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8135 PL_curcop = &PL_compiling;
8137 SAVECOPLINE(PL_curcop);
8138 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8141 PL_hints &= ~HINT_BLOCK_SCOPE;
8144 SAVEGENERICSV(PL_curstash);
8145 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8148 /* Protect sv against leakage caused by fatal warnings. */
8149 if (sv) SAVEFREESV(sv);
8151 /* file becomes the CvFILE. For an XS, it's usually static storage,
8152 and so doesn't get free()d. (It's expected to be from the C pre-
8153 processor __FILE__ directive). But we need a dynamically allocated one,
8154 and we need it to get freed. */
8155 cv = newXS_len_flags(name, len,
8156 sv && SvTYPE(sv) == SVt_PVAV
8159 file ? file : "", "",
8160 &sv, XS_DYNAMIC_FILENAME | flags);
8161 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8170 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8171 const char *const filename, const char *const proto,
8174 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8175 return newXS_len_flags(
8176 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8181 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8182 XSUBADDR_t subaddr, const char *const filename,
8183 const char *const proto, SV **const_svp,
8187 bool interleave = FALSE;
8189 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8192 GV * const gv = gv_fetchpvn(
8193 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8194 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8195 sizeof("__ANON__::__ANON__") - 1,
8196 GV_ADDMULTI | flags, SVt_PVCV);
8199 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8201 if ((cv = (name ? GvCV(gv) : NULL))) {
8203 /* just a cached method */
8207 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8208 /* already defined (or promised) */
8209 /* Redundant check that allows us to avoid creating an SV
8210 most of the time: */
8211 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8212 report_redefined_cv(newSVpvn_flags(
8213 name,len,(flags&SVf_UTF8)|SVs_TEMP
8224 if (cv) /* must reuse cv if autoloaded */
8227 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8231 if (HvENAME_HEK(GvSTASH(gv)))
8232 gv_method_changed(gv); /* newXS */
8238 (void)gv_fetchfile(filename);
8239 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8240 an external constant string */
8241 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8243 CvXSUB(cv) = subaddr;
8246 process_special_blocks(0, name, gv, cv);
8249 if (flags & XS_DYNAMIC_FILENAME) {
8250 CvFILE(cv) = savepv(filename);
8253 sv_setpv(MUTABLE_SV(cv), proto);
8254 if (interleave) LEAVE;
8259 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8261 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8263 PERL_ARGS_ASSERT_NEWSTUB;
8267 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8268 gv_method_changed(gv);
8270 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8275 CvFILE_set_from_cop(cv, PL_curcop);
8276 CvSTASH_set(cv, PL_curstash);
8282 =for apidoc U||newXS
8284 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8285 static storage, as it is used directly as CvFILE(), without a copy being made.
8291 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8293 PERL_ARGS_ASSERT_NEWXS;
8294 return newXS_len_flags(
8295 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8304 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8309 OP* pegop = newOP(OP_NULL, 0);
8314 if (PL_parser && PL_parser->error_count) {
8320 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8321 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8324 if ((cv = GvFORM(gv))) {
8325 if (ckWARN(WARN_REDEFINE)) {
8326 const line_t oldline = CopLINE(PL_curcop);
8327 if (PL_parser && PL_parser->copline != NOLINE)
8328 CopLINE_set(PL_curcop, PL_parser->copline);
8330 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8331 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8333 /* diag_listed_as: Format %s redefined */
8334 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8335 "Format STDOUT redefined");
8337 CopLINE_set(PL_curcop, oldline);
8342 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8344 CvFILE_set_from_cop(cv, PL_curcop);
8347 pad_tidy(padtidy_FORMAT);
8348 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8349 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8350 OpREFCNT_set(CvROOT(cv), 1);
8351 CvSTART(cv) = LINKLIST(CvROOT(cv));
8352 CvROOT(cv)->op_next = 0;
8353 CALL_PEEP(CvSTART(cv));
8354 finalize_optree(CvROOT(cv));
8359 op_getmad(o,pegop,'n');
8360 op_getmad_weak(block, pegop, 'b');
8365 PL_parser->copline = NOLINE;
8373 Perl_newANONLIST(pTHX_ OP *o)
8375 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8379 Perl_newANONHASH(pTHX_ OP *o)
8381 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8385 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8387 return newANONATTRSUB(floor, proto, NULL, block);
8391 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8393 return newUNOP(OP_REFGEN, 0,
8394 newSVOP(OP_ANONCODE, 0,
8395 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8399 Perl_oopsAV(pTHX_ OP *o)
8403 PERL_ARGS_ASSERT_OOPSAV;
8405 switch (o->op_type) {
8408 o->op_type = OP_PADAV;
8409 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8410 return ref(o, OP_RV2AV);
8414 o->op_type = OP_RV2AV;
8415 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8420 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8427 Perl_oopsHV(pTHX_ OP *o)
8431 PERL_ARGS_ASSERT_OOPSHV;
8433 switch (o->op_type) {
8436 o->op_type = OP_PADHV;
8437 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8438 return ref(o, OP_RV2HV);
8442 o->op_type = OP_RV2HV;
8443 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8448 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8455 Perl_newAVREF(pTHX_ OP *o)
8459 PERL_ARGS_ASSERT_NEWAVREF;
8461 if (o->op_type == OP_PADANY) {
8462 o->op_type = OP_PADAV;
8463 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8466 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8467 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8468 "Using an array as a reference is deprecated");
8470 return newUNOP(OP_RV2AV, 0, scalar(o));
8474 Perl_newGVREF(pTHX_ I32 type, OP *o)
8476 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8477 return newUNOP(OP_NULL, 0, o);
8478 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8482 Perl_newHVREF(pTHX_ OP *o)
8486 PERL_ARGS_ASSERT_NEWHVREF;
8488 if (o->op_type == OP_PADANY) {
8489 o->op_type = OP_PADHV;
8490 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8493 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8494 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8495 "Using a hash as a reference is deprecated");
8497 return newUNOP(OP_RV2HV, 0, scalar(o));
8501 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8503 if (o->op_type == OP_PADANY) {
8505 o->op_type = OP_PADCV;
8506 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8508 return newUNOP(OP_RV2CV, flags, scalar(o));
8512 Perl_newSVREF(pTHX_ OP *o)
8516 PERL_ARGS_ASSERT_NEWSVREF;
8518 if (o->op_type == OP_PADANY) {
8519 o->op_type = OP_PADSV;
8520 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8523 return newUNOP(OP_RV2SV, 0, scalar(o));
8526 /* Check routines. See the comments at the top of this file for details
8527 * on when these are called */
8530 Perl_ck_anoncode(pTHX_ OP *o)
8532 PERL_ARGS_ASSERT_CK_ANONCODE;
8534 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8536 cSVOPo->op_sv = NULL;
8541 S_io_hints(pTHX_ OP *o)
8544 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8546 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8549 const char *d = SvPV_const(*svp, len);
8550 const I32 mode = mode_from_discipline(d, len);
8551 if (mode & O_BINARY)
8552 o->op_private |= OPpOPEN_IN_RAW;
8553 else if (mode & O_TEXT)
8554 o->op_private |= OPpOPEN_IN_CRLF;
8557 svp = hv_fetchs(table, "open_OUT", FALSE);
8560 const char *d = SvPV_const(*svp, len);
8561 const I32 mode = mode_from_discipline(d, len);
8562 if (mode & O_BINARY)
8563 o->op_private |= OPpOPEN_OUT_RAW;
8564 else if (mode & O_TEXT)
8565 o->op_private |= OPpOPEN_OUT_CRLF;
8571 Perl_ck_backtick(pTHX_ OP *o)
8575 PERL_ARGS_ASSERT_CK_BACKTICK;
8576 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8577 if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8578 && (gv = gv_override("readpipe",8))) {
8579 newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
8580 cUNOPo->op_first->op_sibling = NULL;
8582 else if (!(o->op_flags & OPf_KIDS))
8583 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8586 op_getmad(o,newop,'O');
8592 S_io_hints(aTHX_ o);
8597 Perl_ck_bitop(pTHX_ OP *o)
8601 PERL_ARGS_ASSERT_CK_BITOP;
8603 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8604 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8605 && (o->op_type == OP_BIT_OR
8606 || o->op_type == OP_BIT_AND
8607 || o->op_type == OP_BIT_XOR))
8609 const OP * const left = cBINOPo->op_first;
8610 const OP * const right = left->op_sibling;
8611 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8612 (left->op_flags & OPf_PARENS) == 0) ||
8613 (OP_IS_NUMCOMPARE(right->op_type) &&
8614 (right->op_flags & OPf_PARENS) == 0))
8615 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8616 "Possible precedence problem on bitwise %c operator",
8617 o->op_type == OP_BIT_OR ? '|'
8618 : o->op_type == OP_BIT_AND ? '&' : '^'
8624 PERL_STATIC_INLINE bool
8625 is_dollar_bracket(pTHX_ const OP * const o)
8628 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8629 && (kid = cUNOPx(o)->op_first)
8630 && kid->op_type == OP_GV
8631 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8635 Perl_ck_cmp(pTHX_ OP *o)
8637 PERL_ARGS_ASSERT_CK_CMP;
8638 if (ckWARN(WARN_SYNTAX)) {
8639 const OP *kid = cUNOPo->op_first;
8642 is_dollar_bracket(aTHX_ kid)
8643 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8645 || ( kid->op_type == OP_CONST
8646 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8648 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8649 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8655 Perl_ck_concat(pTHX_ OP *o)
8657 const OP * const kid = cUNOPo->op_first;
8659 PERL_ARGS_ASSERT_CK_CONCAT;
8660 PERL_UNUSED_CONTEXT;
8662 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8663 !(kUNOP->op_first->op_flags & OPf_MOD))
8664 o->op_flags |= OPf_STACKED;
8669 Perl_ck_spair(pTHX_ OP *o)
8673 PERL_ARGS_ASSERT_CK_SPAIR;
8675 if (o->op_flags & OPf_KIDS) {
8678 const OPCODE type = o->op_type;
8679 o = modkids(ck_fun(o), type);
8680 kid = cUNOPo->op_first;
8681 newop = kUNOP->op_first->op_sibling;
8683 const OPCODE type = newop->op_type;
8684 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8685 type == OP_PADAV || type == OP_PADHV ||
8686 type == OP_RV2AV || type == OP_RV2HV)
8690 op_getmad(kUNOP->op_first,newop,'K');
8692 op_free(kUNOP->op_first);
8694 kUNOP->op_first = newop;
8696 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8697 * and OP_CHOMP into OP_SCHOMP */
8698 o->op_ppaddr = PL_ppaddr[++o->op_type];
8703 Perl_ck_delete(pTHX_ OP *o)
8705 PERL_ARGS_ASSERT_CK_DELETE;
8709 if (o->op_flags & OPf_KIDS) {
8710 OP * const kid = cUNOPo->op_first;
8711 switch (kid->op_type) {
8713 o->op_flags |= OPf_SPECIAL;
8716 o->op_private |= OPpSLICE;
8719 o->op_flags |= OPf_SPECIAL;
8724 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8725 " use array slice");
8727 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8730 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8731 "element or slice");
8733 if (kid->op_private & OPpLVAL_INTRO)
8734 o->op_private |= OPpLVAL_INTRO;
8741 Perl_ck_eof(pTHX_ OP *o)
8745 PERL_ARGS_ASSERT_CK_EOF;
8747 if (o->op_flags & OPf_KIDS) {
8749 if (cLISTOPo->op_first->op_type == OP_STUB) {
8751 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8753 op_getmad(o,newop,'O');
8760 kid = cLISTOPo->op_first;
8761 if (kid->op_type == OP_RV2GV)
8762 kid->op_private |= OPpALLOW_FAKE;
8768 Perl_ck_eval(pTHX_ OP *o)
8772 PERL_ARGS_ASSERT_CK_EVAL;
8774 PL_hints |= HINT_BLOCK_SCOPE;
8775 if (o->op_flags & OPf_KIDS) {
8776 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8779 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8785 cUNOPo->op_first = 0;
8790 NewOp(1101, enter, 1, LOGOP);
8791 enter->op_type = OP_ENTERTRY;
8792 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8793 enter->op_private = 0;
8795 /* establish postfix order */
8796 enter->op_next = (OP*)enter;
8798 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8799 o->op_type = OP_LEAVETRY;
8800 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8801 enter->op_other = o;
8802 op_getmad(oldo,o,'O');
8811 const U8 priv = o->op_private;
8817 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8818 op_getmad(oldo,o,'O');
8820 o->op_targ = (PADOFFSET)PL_hints;
8821 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8822 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8823 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8824 /* Store a copy of %^H that pp_entereval can pick up. */
8825 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8826 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8827 cUNOPo->op_first->op_sibling = hhop;
8828 o->op_private |= OPpEVAL_HAS_HH;
8830 if (!(o->op_private & OPpEVAL_BYTES)
8831 && FEATURE_UNIEVAL_IS_ENABLED)
8832 o->op_private |= OPpEVAL_UNICODE;
8837 Perl_ck_exec(pTHX_ OP *o)
8839 PERL_ARGS_ASSERT_CK_EXEC;
8841 if (o->op_flags & OPf_STACKED) {
8844 kid = cUNOPo->op_first->op_sibling;
8845 if (kid->op_type == OP_RV2GV)
8854 Perl_ck_exists(pTHX_ OP *o)
8858 PERL_ARGS_ASSERT_CK_EXISTS;
8861 if (o->op_flags & OPf_KIDS) {
8862 OP * const kid = cUNOPo->op_first;
8863 if (kid->op_type == OP_ENTERSUB) {
8864 (void) ref(kid, o->op_type);
8865 if (kid->op_type != OP_RV2CV
8866 && !(PL_parser && PL_parser->error_count))
8868 "exists argument is not a subroutine name");
8869 o->op_private |= OPpEXISTS_SUB;
8871 else if (kid->op_type == OP_AELEM)
8872 o->op_flags |= OPf_SPECIAL;
8873 else if (kid->op_type != OP_HELEM)
8874 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8875 "element or a subroutine");
8882 Perl_ck_rvconst(pTHX_ OP *o)
8885 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8887 PERL_ARGS_ASSERT_CK_RVCONST;
8889 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8890 if (o->op_type == OP_RV2CV)
8891 o->op_private &= ~1;
8893 if (kid->op_type == OP_CONST) {
8896 SV * const kidsv = kid->op_sv;
8898 /* Is it a constant from cv_const_sv()? */
8899 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8900 SV * const rsv = SvRV(kidsv);
8901 const svtype type = SvTYPE(rsv);
8902 const char *badtype = NULL;
8904 switch (o->op_type) {
8906 if (type > SVt_PVMG)
8907 badtype = "a SCALAR";
8910 if (type != SVt_PVAV)
8911 badtype = "an ARRAY";
8914 if (type != SVt_PVHV)
8918 if (type != SVt_PVCV)
8923 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8926 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8927 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8928 const char *badthing;
8929 switch (o->op_type) {
8931 badthing = "a SCALAR";
8934 badthing = "an ARRAY";
8937 badthing = "a HASH";
8945 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8946 SVfARG(kidsv), badthing);
8949 * This is a little tricky. We only want to add the symbol if we
8950 * didn't add it in the lexer. Otherwise we get duplicate strict
8951 * warnings. But if we didn't add it in the lexer, we must at
8952 * least pretend like we wanted to add it even if it existed before,
8953 * or we get possible typo warnings. OPpCONST_ENTERED says
8954 * whether the lexer already added THIS instance of this symbol.
8956 iscv = (o->op_type == OP_RV2CV) * 2;
8958 gv = gv_fetchsv(kidsv,
8959 iscv | !(kid->op_private & OPpCONST_ENTERED),
8962 : o->op_type == OP_RV2SV
8964 : o->op_type == OP_RV2AV
8966 : o->op_type == OP_RV2HV
8969 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8971 kid->op_type = OP_GV;
8972 SvREFCNT_dec(kid->op_sv);
8974 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8975 assert (sizeof(PADOP) <= sizeof(SVOP));
8976 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8977 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8979 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8981 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8983 kid->op_private = 0;
8984 kid->op_ppaddr = PL_ppaddr[OP_GV];
8985 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8993 Perl_ck_ftst(pTHX_ OP *o)
8996 const I32 type = o->op_type;
8998 PERL_ARGS_ASSERT_CK_FTST;
9000 if (o->op_flags & OPf_REF) {
9003 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9004 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9005 const OPCODE kidtype = kid->op_type;
9007 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9008 && !kid->op_folded) {
9009 OP * const newop = newGVOP(type, OPf_REF,
9010 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9012 op_getmad(o,newop,'O');
9018 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9019 o->op_private |= OPpFT_ACCESS;
9020 if (PL_check[kidtype] == Perl_ck_ftst
9021 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9022 o->op_private |= OPpFT_STACKED;
9023 kid->op_private |= OPpFT_STACKING;
9024 if (kidtype == OP_FTTTY && (
9025 !(kid->op_private & OPpFT_STACKED)
9026 || kid->op_private & OPpFT_AFTER_t
9028 o->op_private |= OPpFT_AFTER_t;
9037 if (type == OP_FTTTY)
9038 o = newGVOP(type, OPf_REF, PL_stdingv);
9040 o = newUNOP(type, 0, newDEFSVOP());
9041 op_getmad(oldo,o,'O');
9047 Perl_ck_fun(pTHX_ OP *o)
9050 const int type = o->op_type;
9051 I32 oa = PL_opargs[type] >> OASHIFT;
9053 PERL_ARGS_ASSERT_CK_FUN;
9055 if (o->op_flags & OPf_STACKED) {
9056 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9059 return no_fh_allowed(o);
9062 if (o->op_flags & OPf_KIDS) {
9063 OP **tokid = &cLISTOPo->op_first;
9064 OP *kid = cLISTOPo->op_first;
9067 bool seen_optional = FALSE;
9069 if (kid->op_type == OP_PUSHMARK ||
9070 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9072 tokid = &kid->op_sibling;
9073 kid = kid->op_sibling;
9075 if (kid && kid->op_type == OP_COREARGS) {
9076 bool optional = FALSE;
9079 if (oa & OA_OPTIONAL) optional = TRUE;
9082 if (optional) o->op_private |= numargs;
9087 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9088 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
9089 *tokid = kid = newDEFSVOP();
9090 seen_optional = TRUE;
9095 sibl = kid->op_sibling;
9097 if (!sibl && kid->op_type == OP_STUB) {
9104 /* list seen where single (scalar) arg expected? */
9105 if (numargs == 1 && !(oa >> 4)
9106 && kid->op_type == OP_LIST && type != OP_SCALAR)
9108 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9110 if (type != OP_DELETE) scalar(kid);
9121 if ((type == OP_PUSH || type == OP_UNSHIFT)
9122 && !kid->op_sibling)
9123 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9124 "Useless use of %s with no values",
9127 if (kid->op_type == OP_CONST &&
9128 (kid->op_private & OPpCONST_BARE))
9130 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
9131 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
9132 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9133 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
9134 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9136 op_getmad(kid,newop,'K');
9141 kid->op_sibling = sibl;
9144 else if (kid->op_type == OP_CONST
9145 && ( !SvROK(cSVOPx_sv(kid))
9146 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9148 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9149 /* Defer checks to run-time if we have a scalar arg */
9150 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9151 op_lvalue(kid, type);
9154 /* diag_listed_as: push on reference is experimental */
9155 Perl_ck_warner_d(aTHX_
9156 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9157 "%s on reference is experimental",
9162 if (kid->op_type == OP_CONST &&
9163 (kid->op_private & OPpCONST_BARE))
9165 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
9166 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
9167 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9168 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
9169 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9171 op_getmad(kid,newop,'K');
9176 kid->op_sibling = sibl;
9179 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9180 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9181 op_lvalue(kid, type);
9185 OP * const newop = newUNOP(OP_NULL, 0, kid);
9186 kid->op_sibling = 0;
9187 newop->op_next = newop;
9189 kid->op_sibling = sibl;
9194 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9195 if (kid->op_type == OP_CONST &&
9196 (kid->op_private & OPpCONST_BARE))
9198 OP * const newop = newGVOP(OP_GV, 0,
9199 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9200 if (!(o->op_private & 1) && /* if not unop */
9201 kid == cLISTOPo->op_last)
9202 cLISTOPo->op_last = newop;
9204 op_getmad(kid,newop,'K');
9210 else if (kid->op_type == OP_READLINE) {
9211 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9212 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9215 I32 flags = OPf_SPECIAL;
9219 /* is this op a FH constructor? */
9220 if (is_handle_constructor(o,numargs)) {
9221 const char *name = NULL;
9224 bool want_dollar = TRUE;
9227 /* Set a flag to tell rv2gv to vivify
9228 * need to "prove" flag does not mean something
9229 * else already - NI-S 1999/05/07
9232 if (kid->op_type == OP_PADSV) {
9234 = PAD_COMPNAME_SV(kid->op_targ);
9235 name = SvPV_const(namesv, len);
9236 name_utf8 = SvUTF8(namesv);
9238 else if (kid->op_type == OP_RV2SV
9239 && kUNOP->op_first->op_type == OP_GV)
9241 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9243 len = GvNAMELEN(gv);
9244 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9246 else if (kid->op_type == OP_AELEM
9247 || kid->op_type == OP_HELEM)
9250 OP *op = ((BINOP*)kid)->op_first;
9254 const char * const a =
9255 kid->op_type == OP_AELEM ?
9257 if (((op->op_type == OP_RV2AV) ||
9258 (op->op_type == OP_RV2HV)) &&
9259 (firstop = ((UNOP*)op)->op_first) &&
9260 (firstop->op_type == OP_GV)) {
9261 /* packagevar $a[] or $h{} */
9262 GV * const gv = cGVOPx_gv(firstop);
9270 else if (op->op_type == OP_PADAV
9271 || op->op_type == OP_PADHV) {
9272 /* lexicalvar $a[] or $h{} */
9273 const char * const padname =
9274 PAD_COMPNAME_PV(op->op_targ);
9283 name = SvPV_const(tmpstr, len);
9284 name_utf8 = SvUTF8(tmpstr);
9289 name = "__ANONIO__";
9291 want_dollar = FALSE;
9293 op_lvalue(kid, type);
9297 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9298 namesv = PAD_SVl(targ);
9299 if (want_dollar && *name != '$')
9300 sv_setpvs(namesv, "$");
9302 sv_setpvs(namesv, "");
9303 sv_catpvn(namesv, name, len);
9304 if ( name_utf8 ) SvUTF8_on(namesv);
9307 kid->op_sibling = 0;
9308 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
9309 kid->op_targ = targ;
9310 kid->op_private |= priv;
9312 kid->op_sibling = sibl;
9318 if ((type == OP_UNDEF || type == OP_POS)
9319 && numargs == 1 && !(oa >> 4)
9320 && kid->op_type == OP_LIST)
9321 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9322 op_lvalue(scalar(kid), type);
9326 tokid = &kid->op_sibling;
9327 kid = kid->op_sibling;
9330 if (kid && kid->op_type != OP_STUB)
9331 return too_many_arguments_pv(o,OP_DESC(o), 0);
9332 o->op_private |= numargs;
9334 /* FIXME - should the numargs move as for the PERL_MAD case? */
9335 o->op_private |= numargs;
9337 return too_many_arguments_pv(o,OP_DESC(o), 0);
9341 else if (PL_opargs[type] & OA_DEFGV) {
9343 OP *newop = newUNOP(type, 0, newDEFSVOP());
9344 op_getmad(o,newop,'O');
9347 /* Ordering of these two is important to keep f_map.t passing. */
9349 return newUNOP(type, 0, newDEFSVOP());
9354 while (oa & OA_OPTIONAL)
9356 if (oa && oa != OA_LIST)
9357 return too_few_arguments_pv(o,OP_DESC(o), 0);
9363 Perl_ck_glob(pTHX_ OP *o)
9368 PERL_ARGS_ASSERT_CK_GLOB;
9371 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9372 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9374 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9378 * \ null - const(wildcard)
9383 * \ mark - glob - rv2cv
9384 * | \ gv(CORE::GLOBAL::glob)
9386 * \ null - const(wildcard)
9388 o->op_flags |= OPf_SPECIAL;
9389 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9390 o = S_new_entersubop(aTHX_ gv, o);
9391 o = newUNOP(OP_NULL, 0, o);
9392 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9395 else o->op_flags &= ~OPf_SPECIAL;
9396 #if !defined(PERL_EXTERNAL_GLOB)
9399 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9400 newSVpvs("File::Glob"), NULL, NULL, NULL);
9403 #endif /* !PERL_EXTERNAL_GLOB */
9404 gv = (GV *)newSV(0);
9405 gv_init(gv, 0, "", 0, 0);
9407 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9408 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9414 Perl_ck_grep(pTHX_ OP *o)
9419 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9422 PERL_ARGS_ASSERT_CK_GREP;
9424 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9425 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9427 if (o->op_flags & OPf_STACKED) {
9428 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9429 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9430 return no_fh_allowed(o);
9431 o->op_flags &= ~OPf_STACKED;
9433 kid = cLISTOPo->op_first->op_sibling;
9434 if (type == OP_MAPWHILE)
9439 if (PL_parser && PL_parser->error_count)
9441 kid = cLISTOPo->op_first->op_sibling;
9442 if (kid->op_type != OP_NULL)
9443 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9444 kid = kUNOP->op_first;
9446 NewOp(1101, gwop, 1, LOGOP);
9447 gwop->op_type = type;
9448 gwop->op_ppaddr = PL_ppaddr[type];
9450 gwop->op_flags |= OPf_KIDS;
9451 gwop->op_other = LINKLIST(kid);
9452 kid->op_next = (OP*)gwop;
9453 offset = pad_findmy_pvs("$_", 0);
9454 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9455 o->op_private = gwop->op_private = 0;
9456 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9459 o->op_private = gwop->op_private = OPpGREP_LEX;
9460 gwop->op_targ = o->op_targ = offset;
9463 kid = cLISTOPo->op_first->op_sibling;
9464 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9465 op_lvalue(kid, OP_GREPSTART);
9471 Perl_ck_index(pTHX_ OP *o)
9473 PERL_ARGS_ASSERT_CK_INDEX;
9475 if (o->op_flags & OPf_KIDS) {
9476 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9478 kid = kid->op_sibling; /* get past "big" */
9479 if (kid && kid->op_type == OP_CONST) {
9480 const bool save_taint = TAINT_get;
9481 SV *sv = kSVOP->op_sv;
9482 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9484 sv_copypv(sv, kSVOP->op_sv);
9485 SvREFCNT_dec_NN(kSVOP->op_sv);
9488 if (SvOK(sv)) fbm_compile(sv, 0);
9489 TAINT_set(save_taint);
9490 #ifdef NO_TAINT_SUPPORT
9491 PERL_UNUSED_VAR(save_taint);
9499 Perl_ck_lfun(pTHX_ OP *o)
9501 const OPCODE type = o->op_type;
9503 PERL_ARGS_ASSERT_CK_LFUN;
9505 return modkids(ck_fun(o), type);
9509 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9511 PERL_ARGS_ASSERT_CK_DEFINED;
9513 if ((o->op_flags & OPf_KIDS)) {
9514 switch (cUNOPo->op_first->op_type) {
9517 case OP_AASSIGN: /* Is this a good idea? */
9518 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9519 "defined(@array) is deprecated");
9520 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9521 "\t(Maybe you should just omit the defined()?)\n");
9525 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9526 "defined(%%hash) is deprecated");
9527 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9528 "\t(Maybe you should just omit the defined()?)\n");
9539 Perl_ck_readline(pTHX_ OP *o)
9541 PERL_ARGS_ASSERT_CK_READLINE;
9543 if (o->op_flags & OPf_KIDS) {
9544 OP *kid = cLISTOPo->op_first;
9545 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9549 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9551 op_getmad(o,newop,'O');
9561 Perl_ck_rfun(pTHX_ OP *o)
9563 const OPCODE type = o->op_type;
9565 PERL_ARGS_ASSERT_CK_RFUN;
9567 return refkids(ck_fun(o), type);
9571 Perl_ck_listiob(pTHX_ OP *o)
9575 PERL_ARGS_ASSERT_CK_LISTIOB;
9577 kid = cLISTOPo->op_first;
9580 kid = cLISTOPo->op_first;
9582 if (kid->op_type == OP_PUSHMARK)
9583 kid = kid->op_sibling;
9584 if (kid && o->op_flags & OPf_STACKED)
9585 kid = kid->op_sibling;
9586 else if (kid && !kid->op_sibling) { /* print HANDLE; */
9587 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9588 && !kid->op_folded) {
9589 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9590 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9591 cLISTOPo->op_first->op_sibling = kid;
9592 cLISTOPo->op_last = kid;
9593 kid = kid->op_sibling;
9598 op_append_elem(o->op_type, o, newDEFSVOP());
9600 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9605 Perl_ck_smartmatch(pTHX_ OP *o)
9608 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9609 if (0 == (o->op_flags & OPf_SPECIAL)) {
9610 OP *first = cBINOPo->op_first;
9611 OP *second = first->op_sibling;
9613 /* Implicitly take a reference to an array or hash */
9614 first->op_sibling = NULL;
9615 first = cBINOPo->op_first = ref_array_or_hash(first);
9616 second = first->op_sibling = ref_array_or_hash(second);
9618 /* Implicitly take a reference to a regular expression */
9619 if (first->op_type == OP_MATCH) {
9620 first->op_type = OP_QR;
9621 first->op_ppaddr = PL_ppaddr[OP_QR];
9623 if (second->op_type == OP_MATCH) {
9624 second->op_type = OP_QR;
9625 second->op_ppaddr = PL_ppaddr[OP_QR];
9634 Perl_ck_sassign(pTHX_ OP *o)
9637 OP * const kid = cLISTOPo->op_first;
9639 PERL_ARGS_ASSERT_CK_SASSIGN;
9641 /* has a disposable target? */
9642 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9643 && !(kid->op_flags & OPf_STACKED)
9644 /* Cannot steal the second time! */
9645 && !(kid->op_private & OPpTARGET_MY)
9646 /* Keep the full thing for madskills */
9650 OP * const kkid = kid->op_sibling;
9652 /* Can just relocate the target. */
9653 if (kkid && kkid->op_type == OP_PADSV
9654 && !(kkid->op_private & OPpLVAL_INTRO))
9656 kid->op_targ = kkid->op_targ;
9658 /* Now we do not need PADSV and SASSIGN. */
9659 kid->op_sibling = o->op_sibling; /* NULL */
9660 cLISTOPo->op_first = NULL;
9663 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9667 if (kid->op_sibling) {
9668 OP *kkid = kid->op_sibling;
9669 /* For state variable assignment, kkid is a list op whose op_last
9671 if ((kkid->op_type == OP_PADSV ||
9672 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9673 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9676 && (kkid->op_private & OPpLVAL_INTRO)
9677 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9678 const PADOFFSET target = kkid->op_targ;
9679 OP *const other = newOP(OP_PADSV,
9681 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9682 OP *const first = newOP(OP_NULL, 0);
9683 OP *const nullop = newCONDOP(0, first, o, other);
9684 OP *const condop = first->op_next;
9685 /* hijacking PADSTALE for uninitialized state variables */
9686 SvPADSTALE_on(PAD_SVl(target));
9688 condop->op_type = OP_ONCE;
9689 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9690 condop->op_targ = target;
9691 other->op_targ = target;
9693 /* Because we change the type of the op here, we will skip the
9694 assignment binop->op_last = binop->op_first->op_sibling; at the
9695 end of Perl_newBINOP(). So need to do it here. */
9696 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9705 Perl_ck_match(pTHX_ OP *o)
9709 PERL_ARGS_ASSERT_CK_MATCH;
9711 if (o->op_type != OP_QR && PL_compcv) {
9712 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9713 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9714 o->op_targ = offset;
9715 o->op_private |= OPpTARGET_MY;
9718 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9719 o->op_private |= OPpRUNTIME;
9724 Perl_ck_method(pTHX_ OP *o)
9726 OP * const kid = cUNOPo->op_first;
9728 PERL_ARGS_ASSERT_CK_METHOD;
9730 if (kid->op_type == OP_CONST) {
9731 SV* sv = kSVOP->op_sv;
9732 const char * const method = SvPVX_const(sv);
9733 if (!(strchr(method, ':') || strchr(method, '\''))) {
9735 if (!SvIsCOW_shared_hash(sv)) {
9736 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9739 kSVOP->op_sv = NULL;
9741 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9743 op_getmad(o,cmop,'O');
9754 Perl_ck_null(pTHX_ OP *o)
9756 PERL_ARGS_ASSERT_CK_NULL;
9757 PERL_UNUSED_CONTEXT;
9762 Perl_ck_open(pTHX_ OP *o)
9766 PERL_ARGS_ASSERT_CK_OPEN;
9768 S_io_hints(aTHX_ o);
9770 /* In case of three-arg dup open remove strictness
9771 * from the last arg if it is a bareword. */
9772 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9773 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9777 if ((last->op_type == OP_CONST) && /* The bareword. */
9778 (last->op_private & OPpCONST_BARE) &&
9779 (last->op_private & OPpCONST_STRICT) &&
9780 (oa = first->op_sibling) && /* The fh. */
9781 (oa = oa->op_sibling) && /* The mode. */
9782 (oa->op_type == OP_CONST) &&
9783 SvPOK(((SVOP*)oa)->op_sv) &&
9784 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9785 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9786 (last == oa->op_sibling)) /* The bareword. */
9787 last->op_private &= ~OPpCONST_STRICT;
9793 Perl_ck_repeat(pTHX_ OP *o)
9795 PERL_ARGS_ASSERT_CK_REPEAT;
9797 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9798 o->op_private |= OPpREPEAT_DOLIST;
9799 cBINOPo->op_first = force_list(cBINOPo->op_first);
9807 Perl_ck_require(pTHX_ OP *o)
9812 PERL_ARGS_ASSERT_CK_REQUIRE;
9814 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9815 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9817 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9818 SV * const sv = kid->op_sv;
9819 U32 was_readonly = SvREADONLY(sv);
9827 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9832 for (; s < end; s++) {
9833 if (*s == ':' && s[1] == ':') {
9835 Move(s+2, s+1, end - s - 1, char);
9840 sv_catpvs(sv, ".pm");
9841 SvFLAGS(sv) |= was_readonly;
9845 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9846 /* handle override, if any */
9847 && (gv = gv_override("require", 7))) {
9849 if (o->op_flags & OPf_KIDS) {
9850 kid = cUNOPo->op_first;
9851 cUNOPo->op_first = NULL;
9859 newop = S_new_entersubop(aTHX_ gv, kid);
9860 op_getmad(o,newop,'O');
9864 return scalar(ck_fun(o));
9868 Perl_ck_return(pTHX_ OP *o)
9873 PERL_ARGS_ASSERT_CK_RETURN;
9875 kid = cLISTOPo->op_first->op_sibling;
9876 if (CvLVALUE(PL_compcv)) {
9877 for (; kid; kid = kid->op_sibling)
9878 op_lvalue(kid, OP_LEAVESUBLV);
9885 Perl_ck_select(pTHX_ OP *o)
9890 PERL_ARGS_ASSERT_CK_SELECT;
9892 if (o->op_flags & OPf_KIDS) {
9893 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9894 if (kid && kid->op_sibling) {
9895 o->op_type = OP_SSELECT;
9896 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9898 return fold_constants(op_integerize(op_std_init(o)));
9902 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9903 if (kid && kid->op_type == OP_RV2GV)
9904 kid->op_private &= ~HINT_STRICT_REFS;
9909 Perl_ck_shift(pTHX_ OP *o)
9912 const I32 type = o->op_type;
9914 PERL_ARGS_ASSERT_CK_SHIFT;
9916 if (!(o->op_flags & OPf_KIDS)) {
9919 if (!CvUNIQUE(PL_compcv)) {
9920 o->op_flags |= OPf_SPECIAL;
9924 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9927 OP * const oldo = o;
9928 o = newUNOP(type, 0, scalar(argop));
9929 op_getmad(oldo,o,'O');
9934 return newUNOP(type, 0, scalar(argop));
9937 return scalar(ck_fun(o));
9941 Perl_ck_sort(pTHX_ OP *o)
9947 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9950 PERL_ARGS_ASSERT_CK_SORT;
9953 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9955 const I32 sorthints = (I32)SvIV(*svp);
9956 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9957 o->op_private |= OPpSORT_QSORT;
9958 if ((sorthints & HINT_SORT_STABLE) != 0)
9959 o->op_private |= OPpSORT_STABLE;
9963 if (o->op_flags & OPf_STACKED)
9965 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9966 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9967 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9969 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9971 if (kid->op_type == OP_LEAVE)
9972 op_null(kid); /* wipe out leave */
9973 /* Prevent execution from escaping out of the sort block. */
9976 /* provide scalar context for comparison function/block */
9977 kid = scalar(firstkid);
9979 o->op_flags |= OPf_SPECIAL;
9982 firstkid = firstkid->op_sibling;
9985 for (kid = firstkid; kid; kid = kid->op_sibling) {
9986 /* provide list context for arguments */
9989 op_lvalue(kid, OP_GREPSTART);
9996 S_simplify_sort(pTHX_ OP *o)
9999 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
10003 const char *gvname;
10006 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10008 kid = kUNOP->op_first; /* get past null */
10009 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10010 && kid->op_type != OP_LEAVE)
10012 kid = kLISTOP->op_last; /* get past scope */
10013 switch(kid->op_type) {
10017 if (!have_scopeop) goto padkids;
10022 k = kid; /* remember this node*/
10023 if (kBINOP->op_first->op_type != OP_RV2SV
10024 || kBINOP->op_last ->op_type != OP_RV2SV)
10027 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10028 then used in a comparison. This catches most, but not
10029 all cases. For instance, it catches
10030 sort { my($a); $a <=> $b }
10032 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10033 (although why you'd do that is anyone's guess).
10037 if (!ckWARN(WARN_SYNTAX)) return;
10038 kid = kBINOP->op_first;
10040 if (kid->op_type == OP_PADSV) {
10041 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
10042 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10043 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10044 /* diag_listed_as: "my %s" used in sort comparison */
10045 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10046 "\"%s %s\" used in sort comparison",
10047 SvPAD_STATE(name) ? "state" : "my",
10050 } while ((kid = kid->op_sibling));
10053 kid = kBINOP->op_first; /* get past cmp */
10054 if (kUNOP->op_first->op_type != OP_GV)
10056 kid = kUNOP->op_first; /* get past rv2sv */
10058 if (GvSTASH(gv) != PL_curstash)
10060 gvname = GvNAME(gv);
10061 if (*gvname == 'a' && gvname[1] == '\0')
10063 else if (*gvname == 'b' && gvname[1] == '\0')
10068 kid = k; /* back to cmp */
10069 /* already checked above that it is rv2sv */
10070 kid = kBINOP->op_last; /* down to 2nd arg */
10071 if (kUNOP->op_first->op_type != OP_GV)
10073 kid = kUNOP->op_first; /* get past rv2sv */
10075 if (GvSTASH(gv) != PL_curstash)
10077 gvname = GvNAME(gv);
10079 ? !(*gvname == 'a' && gvname[1] == '\0')
10080 : !(*gvname == 'b' && gvname[1] == '\0'))
10082 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10084 o->op_private |= OPpSORT_DESCEND;
10085 if (k->op_type == OP_NCMP)
10086 o->op_private |= OPpSORT_NUMERIC;
10087 if (k->op_type == OP_I_NCMP)
10088 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10089 kid = cLISTOPo->op_first->op_sibling;
10090 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
10092 op_getmad(kid,o,'S'); /* then delete it */
10094 op_free(kid); /* then delete it */
10099 Perl_ck_split(pTHX_ OP *o)
10104 PERL_ARGS_ASSERT_CK_SPLIT;
10106 if (o->op_flags & OPf_STACKED)
10107 return no_fh_allowed(o);
10109 kid = cLISTOPo->op_first;
10110 if (kid->op_type != OP_NULL)
10111 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10112 kid = kid->op_sibling;
10113 op_free(cLISTOPo->op_first);
10115 cLISTOPo->op_first = kid;
10117 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
10118 cLISTOPo->op_last = kid; /* There was only one element previously */
10121 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10122 OP * const sibl = kid->op_sibling;
10123 kid->op_sibling = 0;
10124 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
10125 if (cLISTOPo->op_first == cLISTOPo->op_last)
10126 cLISTOPo->op_last = kid;
10127 cLISTOPo->op_first = kid;
10128 kid->op_sibling = sibl;
10131 kid->op_type = OP_PUSHRE;
10132 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10134 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10135 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10136 "Use of /g modifier is meaningless in split");
10139 if (!kid->op_sibling)
10140 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10142 kid = kid->op_sibling;
10145 if (!kid->op_sibling)
10147 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10148 o->op_private |= OPpSPLIT_IMPLIM;
10150 assert(kid->op_sibling);
10152 kid = kid->op_sibling;
10155 if (kid->op_sibling)
10156 return too_many_arguments_pv(o,OP_DESC(o), 0);
10162 Perl_ck_join(pTHX_ OP *o)
10164 const OP * const kid = cLISTOPo->op_first->op_sibling;
10166 PERL_ARGS_ASSERT_CK_JOIN;
10168 if (kid && kid->op_type == OP_MATCH) {
10169 if (ckWARN(WARN_SYNTAX)) {
10170 const REGEXP *re = PM_GETRE(kPMOP);
10172 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10173 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10174 : newSVpvs_flags( "STRING", SVs_TEMP );
10175 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10176 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10177 SVfARG(msg), SVfARG(msg));
10184 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10186 Examines an op, which is expected to identify a subroutine at runtime,
10187 and attempts to determine at compile time which subroutine it identifies.
10188 This is normally used during Perl compilation to determine whether
10189 a prototype can be applied to a function call. I<cvop> is the op
10190 being considered, normally an C<rv2cv> op. A pointer to the identified
10191 subroutine is returned, if it could be determined statically, and a null
10192 pointer is returned if it was not possible to determine statically.
10194 Currently, the subroutine can be identified statically if the RV that the
10195 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10196 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10197 suitable if the constant value must be an RV pointing to a CV. Details of
10198 this process may change in future versions of Perl. If the C<rv2cv> op
10199 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10200 the subroutine statically: this flag is used to suppress compile-time
10201 magic on a subroutine call, forcing it to use default runtime behaviour.
10203 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10204 of a GV reference is modified. If a GV was examined and its CV slot was
10205 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10206 If the op is not optimised away, and the CV slot is later populated with
10207 a subroutine having a prototype, that flag eventually triggers the warning
10208 "called too early to check prototype".
10210 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10211 of returning a pointer to the subroutine it returns a pointer to the
10212 GV giving the most appropriate name for the subroutine in this context.
10213 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10214 (C<CvANON>) subroutine that is referenced through a GV it will be the
10215 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10216 A null pointer is returned as usual if there is no statically-determinable
10222 /* shared by toke.c:yylex */
10224 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10226 PADNAME *name = PAD_COMPNAME(off);
10227 CV *compcv = PL_compcv;
10228 while (PadnameOUTER(name)) {
10229 assert(PARENT_PAD_INDEX(name));
10230 compcv = CvOUTSIDE(PL_compcv);
10231 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10232 [off = PARENT_PAD_INDEX(name)];
10234 assert(!PadnameIsOUR(name));
10235 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10236 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10238 assert(mg->mg_obj);
10239 return (CV *)mg->mg_obj;
10241 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10245 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10250 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10251 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10252 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10253 if (cvop->op_type != OP_RV2CV)
10255 if (cvop->op_private & OPpENTERSUB_AMPER)
10257 if (!(cvop->op_flags & OPf_KIDS))
10259 rvop = cUNOPx(cvop)->op_first;
10260 switch (rvop->op_type) {
10262 gv = cGVOPx_gv(rvop);
10265 if (flags & RV2CVOPCV_MARK_EARLY)
10266 rvop->op_private |= OPpEARLY_CV;
10271 SV *rv = cSVOPx_sv(rvop);
10274 cv = (CV*)SvRV(rv);
10278 cv = find_lexical_cv(rvop->op_targ);
10285 if (SvTYPE((SV*)cv) != SVt_PVCV)
10287 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10288 if (!CvANON(cv) || !gv)
10297 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10299 Performs the default fixup of the arguments part of an C<entersub>
10300 op tree. This consists of applying list context to each of the
10301 argument ops. This is the standard treatment used on a call marked
10302 with C<&>, or a method call, or a call through a subroutine reference,
10303 or any other call where the callee can't be identified at compile time,
10304 or a call where the callee has no prototype.
10310 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10313 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10314 aop = cUNOPx(entersubop)->op_first;
10315 if (!aop->op_sibling)
10316 aop = cUNOPx(aop)->op_first;
10317 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10318 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10320 op_lvalue(aop, OP_ENTERSUB);
10327 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10329 Performs the fixup of the arguments part of an C<entersub> op tree
10330 based on a subroutine prototype. This makes various modifications to
10331 the argument ops, from applying context up to inserting C<refgen> ops,
10332 and checking the number and syntactic types of arguments, as directed by
10333 the prototype. This is the standard treatment used on a subroutine call,
10334 not marked with C<&>, where the callee can be identified at compile time
10335 and has a prototype.
10337 I<protosv> supplies the subroutine prototype to be applied to the call.
10338 It may be a normal defined scalar, of which the string value will be used.
10339 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10340 that has been cast to C<SV*>) which has a prototype. The prototype
10341 supplied, in whichever form, does not need to match the actual callee
10342 referenced by the op tree.
10344 If the argument ops disagree with the prototype, for example by having
10345 an unacceptable number of arguments, a valid op tree is returned anyway.
10346 The error is reflected in the parser state, normally resulting in a single
10347 exception at the top level of parsing which covers all the compilation
10348 errors that occurred. In the error message, the callee is referred to
10349 by the name defined by the I<namegv> parameter.
10355 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10358 const char *proto, *proto_end;
10359 OP *aop, *prev, *cvop;
10362 I32 contextclass = 0;
10363 const char *e = NULL;
10364 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10365 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10366 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10367 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10368 if (SvTYPE(protosv) == SVt_PVCV)
10369 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10370 else proto = SvPV(protosv, proto_len);
10371 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10372 proto_end = proto + proto_len;
10373 aop = cUNOPx(entersubop)->op_first;
10374 if (!aop->op_sibling)
10375 aop = cUNOPx(aop)->op_first;
10377 aop = aop->op_sibling;
10378 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10379 while (aop != cvop) {
10381 if (PL_madskills && aop->op_type == OP_STUB) {
10382 aop = aop->op_sibling;
10385 if (PL_madskills && aop->op_type == OP_NULL)
10386 o3 = ((UNOP*)aop)->op_first;
10390 if (proto >= proto_end)
10391 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10399 /* _ must be at the end */
10400 if (proto[1] && !strchr(";@%", proto[1]))
10415 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10417 arg == 1 ? "block or sub {}" : "sub {}",
10421 /* '*' allows any scalar type, including bareword */
10424 if (o3->op_type == OP_RV2GV)
10425 goto wrapref; /* autoconvert GLOB -> GLOBref */
10426 else if (o3->op_type == OP_CONST)
10427 o3->op_private &= ~OPpCONST_STRICT;
10428 else if (o3->op_type == OP_ENTERSUB) {
10429 /* accidental subroutine, revert to bareword */
10430 OP *gvop = ((UNOP*)o3)->op_first;
10431 if (gvop && gvop->op_type == OP_NULL) {
10432 gvop = ((UNOP*)gvop)->op_first;
10434 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10437 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10438 (gvop = ((UNOP*)gvop)->op_first) &&
10439 gvop->op_type == OP_GV)
10441 GV * const gv = cGVOPx_gv(gvop);
10442 OP * const sibling = aop->op_sibling;
10443 SV * const n = newSVpvs("");
10445 OP * const oldaop = aop;
10449 gv_fullname4(n, gv, "", FALSE);
10450 aop = newSVOP(OP_CONST, 0, n);
10451 op_getmad(oldaop,aop,'O');
10452 prev->op_sibling = aop;
10453 aop->op_sibling = sibling;
10463 if (o3->op_type == OP_RV2AV ||
10464 o3->op_type == OP_PADAV ||
10465 o3->op_type == OP_RV2HV ||
10466 o3->op_type == OP_PADHV
10472 case '[': case ']':
10479 switch (*proto++) {
10481 if (contextclass++ == 0) {
10482 e = strchr(proto, ']');
10483 if (!e || e == proto)
10491 if (contextclass) {
10492 const char *p = proto;
10493 const char *const end = proto;
10495 while (*--p != '[')
10496 /* \[$] accepts any scalar lvalue */
10498 && Perl_op_lvalue_flags(aTHX_
10500 OP_READ, /* not entersub */
10503 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10504 (int)(end - p), p),
10510 if (o3->op_type == OP_RV2GV)
10513 bad_type_gv(arg, "symbol", namegv, 0, o3);
10516 if (o3->op_type == OP_ENTERSUB)
10519 bad_type_gv(arg, "subroutine entry", namegv, 0,
10523 if (o3->op_type == OP_RV2SV ||
10524 o3->op_type == OP_PADSV ||
10525 o3->op_type == OP_HELEM ||
10526 o3->op_type == OP_AELEM)
10528 if (!contextclass) {
10529 /* \$ accepts any scalar lvalue */
10530 if (Perl_op_lvalue_flags(aTHX_
10532 OP_READ, /* not entersub */
10535 bad_type_gv(arg, "scalar", namegv, 0, o3);
10539 if (o3->op_type == OP_RV2AV ||
10540 o3->op_type == OP_PADAV)
10543 bad_type_gv(arg, "array", namegv, 0, o3);
10546 if (o3->op_type == OP_RV2HV ||
10547 o3->op_type == OP_PADHV)
10550 bad_type_gv(arg, "hash", namegv, 0, o3);
10554 OP* const kid = aop;
10555 OP* const sib = kid->op_sibling;
10556 kid->op_sibling = 0;
10557 aop = newUNOP(OP_REFGEN, 0, kid);
10558 aop->op_sibling = sib;
10559 prev->op_sibling = aop;
10561 if (contextclass && e) {
10566 default: goto oops;
10576 SV* const tmpsv = sv_newmortal();
10577 gv_efullname3(tmpsv, namegv, NULL);
10578 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10579 SVfARG(tmpsv), SVfARG(protosv));
10583 op_lvalue(aop, OP_ENTERSUB);
10585 aop = aop->op_sibling;
10587 if (aop == cvop && *proto == '_') {
10588 /* generate an access to $_ */
10589 aop = newDEFSVOP();
10590 aop->op_sibling = prev->op_sibling;
10591 prev->op_sibling = aop; /* instead of cvop */
10593 if (!optional && proto_end > proto &&
10594 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10595 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10600 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10602 Performs the fixup of the arguments part of an C<entersub> op tree either
10603 based on a subroutine prototype or using default list-context processing.
10604 This is the standard treatment used on a subroutine call, not marked
10605 with C<&>, where the callee can be identified at compile time.
10607 I<protosv> supplies the subroutine prototype to be applied to the call,
10608 or indicates that there is no prototype. It may be a normal scalar,
10609 in which case if it is defined then the string value will be used
10610 as a prototype, and if it is undefined then there is no prototype.
10611 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10612 that has been cast to C<SV*>), of which the prototype will be used if it
10613 has one. The prototype (or lack thereof) supplied, in whichever form,
10614 does not need to match the actual callee referenced by the op tree.
10616 If the argument ops disagree with the prototype, for example by having
10617 an unacceptable number of arguments, a valid op tree is returned anyway.
10618 The error is reflected in the parser state, normally resulting in a single
10619 exception at the top level of parsing which covers all the compilation
10620 errors that occurred. In the error message, the callee is referred to
10621 by the name defined by the I<namegv> parameter.
10627 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10628 GV *namegv, SV *protosv)
10630 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10631 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10632 return ck_entersub_args_proto(entersubop, namegv, protosv);
10634 return ck_entersub_args_list(entersubop);
10638 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10640 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10641 OP *aop = cUNOPx(entersubop)->op_first;
10643 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10647 if (!aop->op_sibling)
10648 aop = cUNOPx(aop)->op_first;
10649 aop = aop->op_sibling;
10650 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10651 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10652 aop = aop->op_sibling;
10655 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10657 op_free(entersubop);
10658 switch(GvNAME(namegv)[2]) {
10659 case 'F': return newSVOP(OP_CONST, 0,
10660 newSVpv(CopFILE(PL_curcop),0));
10661 case 'L': return newSVOP(
10663 Perl_newSVpvf(aTHX_
10664 "%"IVdf, (IV)CopLINE(PL_curcop)
10667 case 'P': return newSVOP(OP_CONST, 0,
10669 ? newSVhek(HvNAME_HEK(PL_curstash))
10680 bool seenarg = FALSE;
10682 if (!aop->op_sibling)
10683 aop = cUNOPx(aop)->op_first;
10686 aop = aop->op_sibling;
10687 prev->op_sibling = NULL;
10690 prev=cvop, cvop = cvop->op_sibling)
10692 if (PL_madskills && cvop->op_sibling
10693 && cvop->op_type != OP_STUB) seenarg = TRUE
10696 prev->op_sibling = NULL;
10697 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10699 if (aop == cvop) aop = NULL;
10700 op_free(entersubop);
10702 if (opnum == OP_ENTEREVAL
10703 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10704 flags |= OPpEVAL_BYTES <<8;
10706 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10708 case OA_BASEOP_OR_UNOP:
10709 case OA_FILESTATOP:
10710 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10714 if (!PL_madskills || seenarg)
10716 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10719 return opnum == OP_RUNCV
10720 ? newPVOP(OP_RUNCV,0,NULL)
10723 return convert(opnum,0,aop);
10731 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10733 Retrieves the function that will be used to fix up a call to I<cv>.
10734 Specifically, the function is applied to an C<entersub> op tree for a
10735 subroutine call, not marked with C<&>, where the callee can be identified
10736 at compile time as I<cv>.
10738 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10739 argument for it is returned in I<*ckobj_p>. The function is intended
10740 to be called in this manner:
10742 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10744 In this call, I<entersubop> is a pointer to the C<entersub> op,
10745 which may be replaced by the check function, and I<namegv> is a GV
10746 supplying the name that should be used by the check function to refer
10747 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10748 It is permitted to apply the check function in non-standard situations,
10749 such as to a call to a different subroutine or to a method call.
10751 By default, the function is
10752 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10753 and the SV parameter is I<cv> itself. This implements standard
10754 prototype processing. It can be changed, for a particular subroutine,
10755 by L</cv_set_call_checker>.
10761 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10764 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10765 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10767 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10768 *ckobj_p = callmg->mg_obj;
10770 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10771 *ckobj_p = (SV*)cv;
10776 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10778 Sets the function that will be used to fix up a call to I<cv>.
10779 Specifically, the function is applied to an C<entersub> op tree for a
10780 subroutine call, not marked with C<&>, where the callee can be identified
10781 at compile time as I<cv>.
10783 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10784 for it is supplied in I<ckobj>. The function should be defined like this:
10786 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10788 It is intended to be called in this manner:
10790 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10792 In this call, I<entersubop> is a pointer to the C<entersub> op,
10793 which may be replaced by the check function, and I<namegv> is a GV
10794 supplying the name that should be used by the check function to refer
10795 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10796 It is permitted to apply the check function in non-standard situations,
10797 such as to a call to a different subroutine or to a method call.
10799 The current setting for a particular CV can be retrieved by
10800 L</cv_get_call_checker>.
10806 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10808 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10809 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10810 if (SvMAGICAL((SV*)cv))
10811 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10814 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10815 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10816 if (callmg->mg_flags & MGf_REFCOUNTED) {
10817 SvREFCNT_dec(callmg->mg_obj);
10818 callmg->mg_flags &= ~MGf_REFCOUNTED;
10820 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10821 callmg->mg_obj = ckobj;
10822 if (ckobj != (SV*)cv) {
10823 SvREFCNT_inc_simple_void_NN(ckobj);
10824 callmg->mg_flags |= MGf_REFCOUNTED;
10826 callmg->mg_flags |= MGf_COPY;
10831 Perl_ck_subr(pTHX_ OP *o)
10837 PERL_ARGS_ASSERT_CK_SUBR;
10839 aop = cUNOPx(o)->op_first;
10840 if (!aop->op_sibling)
10841 aop = cUNOPx(aop)->op_first;
10842 aop = aop->op_sibling;
10843 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10844 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10845 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10847 o->op_private &= ~1;
10848 o->op_private |= OPpENTERSUB_HASTARG;
10849 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10850 if (PERLDB_SUB && PL_curstash != PL_debstash)
10851 o->op_private |= OPpENTERSUB_DB;
10852 if (cvop->op_type == OP_RV2CV) {
10853 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10855 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10856 if (aop->op_type == OP_CONST)
10857 aop->op_private &= ~OPpCONST_STRICT;
10858 else if (aop->op_type == OP_LIST) {
10859 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10860 if (sib && sib->op_type == OP_CONST)
10861 sib->op_private &= ~OPpCONST_STRICT;
10866 return ck_entersub_args_list(o);
10868 Perl_call_checker ckfun;
10870 cv_get_call_checker(cv, &ckfun, &ckobj);
10871 if (!namegv) { /* expletive! */
10872 /* XXX The call checker API is public. And it guarantees that
10873 a GV will be provided with the right name. So we have
10874 to create a GV. But it is still not correct, as its
10875 stringification will include the package. What we
10876 really need is a new call checker API that accepts a
10877 GV or string (or GV or CV). */
10878 HEK * const hek = CvNAME_HEK(cv);
10879 /* After a syntax error in a lexical sub, the cv that
10880 rv2cv_op_cv returns may be a nameless stub. */
10881 if (!hek) return ck_entersub_args_list(o);;
10882 namegv = (GV *)sv_newmortal();
10883 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10884 SVf_UTF8 * !!HEK_UTF8(hek));
10886 return ckfun(aTHX_ o, namegv, ckobj);
10891 Perl_ck_svconst(pTHX_ OP *o)
10893 SV * const sv = cSVOPo->op_sv;
10894 PERL_ARGS_ASSERT_CK_SVCONST;
10895 PERL_UNUSED_CONTEXT;
10896 #ifdef PERL_OLD_COPY_ON_WRITE
10897 if (SvIsCOW(sv)) sv_force_normal(sv);
10898 #elif defined(PERL_NEW_COPY_ON_WRITE)
10899 /* Since the read-only flag may be used to protect a string buffer, we
10900 cannot do copy-on-write with existing read-only scalars that are not
10901 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10902 that constant, mark the constant as COWable here, if it is not
10903 already read-only. */
10904 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10907 # ifdef PERL_DEBUG_READONLY_COW
10917 Perl_ck_trunc(pTHX_ OP *o)
10919 PERL_ARGS_ASSERT_CK_TRUNC;
10921 if (o->op_flags & OPf_KIDS) {
10922 SVOP *kid = (SVOP*)cUNOPo->op_first;
10924 if (kid->op_type == OP_NULL)
10925 kid = (SVOP*)kid->op_sibling;
10926 if (kid && kid->op_type == OP_CONST &&
10927 (kid->op_private & OPpCONST_BARE) &&
10930 o->op_flags |= OPf_SPECIAL;
10931 kid->op_private &= ~OPpCONST_STRICT;
10938 Perl_ck_substr(pTHX_ OP *o)
10940 PERL_ARGS_ASSERT_CK_SUBSTR;
10943 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10944 OP *kid = cLISTOPo->op_first;
10946 if (kid->op_type == OP_NULL)
10947 kid = kid->op_sibling;
10949 kid->op_flags |= OPf_MOD;
10956 Perl_ck_tell(pTHX_ OP *o)
10958 PERL_ARGS_ASSERT_CK_TELL;
10960 if (o->op_flags & OPf_KIDS) {
10961 OP *kid = cLISTOPo->op_first;
10962 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10963 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10969 Perl_ck_each(pTHX_ OP *o)
10972 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10973 const unsigned orig_type = o->op_type;
10974 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10975 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10976 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10977 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10979 PERL_ARGS_ASSERT_CK_EACH;
10982 switch (kid->op_type) {
10988 CHANGE_TYPE(o, array_type);
10991 if (kid->op_private == OPpCONST_BARE
10992 || !SvROK(cSVOPx_sv(kid))
10993 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10994 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10996 /* we let ck_fun handle it */
10999 CHANGE_TYPE(o, ref_type);
11003 /* if treating as a reference, defer additional checks to runtime */
11004 if (o->op_type == ref_type) {
11005 /* diag_listed_as: keys on reference is experimental */
11006 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11007 "%s is experimental", PL_op_desc[ref_type]);
11014 Perl_ck_length(pTHX_ OP *o)
11016 PERL_ARGS_ASSERT_CK_LENGTH;
11020 if (ckWARN(WARN_SYNTAX)) {
11021 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11025 const bool hash = kid->op_type == OP_PADHV
11026 || kid->op_type == OP_RV2HV;
11027 switch (kid->op_type) {
11032 name = S_op_varname(aTHX_ kid);
11038 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11039 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11041 name, hash ? "keys " : "", name
11044 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11045 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11046 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11048 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11049 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11050 "length() used on @array (did you mean \"scalar(@array)\"?)");
11057 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11058 and modify the optree to make them work inplace */
11061 S_inplace_aassign(pTHX_ OP *o) {
11063 OP *modop, *modop_pushmark;
11065 OP *oleft, *oleft_pushmark;
11067 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11069 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11071 assert(cUNOPo->op_first->op_type == OP_NULL);
11072 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11073 assert(modop_pushmark->op_type == OP_PUSHMARK);
11074 modop = modop_pushmark->op_sibling;
11076 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11079 /* no other operation except sort/reverse */
11080 if (modop->op_sibling)
11083 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11084 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
11086 if (modop->op_flags & OPf_STACKED) {
11087 /* skip sort subroutine/block */
11088 assert(oright->op_type == OP_NULL);
11089 oright = oright->op_sibling;
11092 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
11093 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
11094 assert(oleft_pushmark->op_type == OP_PUSHMARK);
11095 oleft = oleft_pushmark->op_sibling;
11097 /* Check the lhs is an array */
11099 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11100 || oleft->op_sibling
11101 || (oleft->op_private & OPpLVAL_INTRO)
11105 /* Only one thing on the rhs */
11106 if (oright->op_sibling)
11109 /* check the array is the same on both sides */
11110 if (oleft->op_type == OP_RV2AV) {
11111 if (oright->op_type != OP_RV2AV
11112 || !cUNOPx(oright)->op_first
11113 || cUNOPx(oright)->op_first->op_type != OP_GV
11114 || cUNOPx(oleft )->op_first->op_type != OP_GV
11115 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11116 cGVOPx_gv(cUNOPx(oright)->op_first)
11120 else if (oright->op_type != OP_PADAV
11121 || oright->op_targ != oleft->op_targ
11125 /* This actually is an inplace assignment */
11127 modop->op_private |= OPpSORT_INPLACE;
11129 /* transfer MODishness etc from LHS arg to RHS arg */
11130 oright->op_flags = oleft->op_flags;
11132 /* remove the aassign op and the lhs */
11134 op_null(oleft_pushmark);
11135 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11136 op_null(cUNOPx(oleft)->op_first);
11140 #define MAX_DEFERRED 4
11144 if (defer_ix == (MAX_DEFERRED-1)) { \
11145 CALL_RPEEP(defer_queue[defer_base]); \
11146 defer_base = (defer_base + 1) % MAX_DEFERRED; \
11149 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
11152 #define IS_AND_OP(o) (o->op_type == OP_AND)
11153 #define IS_OR_OP(o) (o->op_type == OP_OR)
11156 S_null_listop_in_list_context(pTHX_ OP *o)
11160 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
11162 /* This is an OP_LIST in list context. That means we
11163 * can ditch the OP_LIST and the OP_PUSHMARK within. */
11165 kid = cLISTOPo->op_first;
11166 /* Find the end of the chain of OPs executed within the OP_LIST. */
11167 while (kid->op_next != o) {
11169 kid = kid->op_next;
11172 kid->op_next = o->op_next; /* patch list out of exec chain */
11173 op_null(cUNOPo->op_first); /* NULL the pushmark */
11174 op_null(o); /* NULL the list */
11177 /* A peephole optimizer. We visit the ops in the order they're to execute.
11178 * See the comments at the top of this file for more details about when
11179 * peep() is called */
11182 Perl_rpeep(pTHX_ OP *o)
11186 OP* oldoldop = NULL;
11187 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11188 int defer_base = 0;
11191 if (!o || o->op_opt)
11195 SAVEVPTR(PL_curcop);
11196 for (;; o = o->op_next) {
11197 if (o && o->op_opt)
11200 while (defer_ix >= 0)
11201 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
11205 /* By default, this op has now been optimised. A couple of cases below
11206 clear this again. */
11211 /* The following will have the OP_LIST and OP_PUSHMARK
11212 * patched out later IF the OP_LIST is in list context.
11213 * So in that case, we can set the this OP's op_next
11214 * to skip to after the OP_PUSHMARK:
11220 * will eventually become:
11223 * - ex-pushmark -> -
11229 OP *other_pushmark;
11230 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11231 && (sibling = o->op_sibling)
11232 && sibling->op_type == OP_LIST
11233 /* This KIDS check is likely superfluous since OP_LIST
11234 * would otherwise be an OP_STUB. */
11235 && sibling->op_flags & OPf_KIDS
11236 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11237 && (other_pushmark = cLISTOPx(sibling)->op_first)
11238 /* Pointer equality also effectively checks that it's a
11240 && other_pushmark == o->op_next)
11242 o->op_next = other_pushmark->op_next;
11243 null_listop_in_list_context(sibling);
11247 switch (o->op_type) {
11249 PL_curcop = ((COP*)o); /* for warnings */
11252 PL_curcop = ((COP*)o); /* for warnings */
11254 /* Optimise a "return ..." at the end of a sub to just be "...".
11255 * This saves 2 ops. Before:
11256 * 1 <;> nextstate(main 1 -e:1) v ->2
11257 * 4 <@> return K ->5
11258 * 2 <0> pushmark s ->3
11259 * - <1> ex-rv2sv sK/1 ->4
11260 * 3 <#> gvsv[*cat] s ->4
11263 * - <@> return K ->-
11264 * - <0> pushmark s ->2
11265 * - <1> ex-rv2sv sK/1 ->-
11266 * 2 <$> gvsv(*cat) s ->3
11269 OP *next = o->op_next;
11270 OP *sibling = o->op_sibling;
11271 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11272 && OP_TYPE_IS(sibling, OP_RETURN)
11273 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11274 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11275 && cUNOPx(sibling)->op_first == next
11276 && next->op_sibling && next->op_sibling->op_next
11279 /* Look through the PUSHMARK's siblings for one that
11280 * points to the RETURN */
11281 OP *top = next->op_sibling;
11282 while (top && top->op_next) {
11283 if (top->op_next == sibling) {
11284 top->op_next = sibling->op_next;
11285 o->op_next = next->op_next;
11288 top = top->op_sibling;
11293 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11295 * This latter form is then suitable for conversion into padrange
11296 * later on. Convert:
11298 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11302 * nextstate1 -> listop -> nextstate3
11304 * pushmark -> padop1 -> padop2
11306 if (o->op_next && (
11307 o->op_next->op_type == OP_PADSV
11308 || o->op_next->op_type == OP_PADAV
11309 || o->op_next->op_type == OP_PADHV
11311 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11312 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11313 && o->op_next->op_next->op_next && (
11314 o->op_next->op_next->op_next->op_type == OP_PADSV
11315 || o->op_next->op_next->op_next->op_type == OP_PADAV
11316 || o->op_next->op_next->op_next->op_type == OP_PADHV
11318 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11319 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11320 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11321 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11327 first = o->op_next;
11328 last = o->op_next->op_next->op_next;
11330 newop = newLISTOP(OP_LIST, 0, first, last);
11331 newop->op_flags |= OPf_PARENS;
11332 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11334 /* Kill nextstate2 between padop1/padop2 */
11335 op_free(first->op_next);
11337 first->op_next = last; /* padop2 */
11338 first->op_sibling = last; /* ... */
11339 o->op_next = cUNOPx(newop)->op_first; /* pushmark */
11340 o->op_next->op_next = first; /* padop1 */
11341 o->op_next->op_sibling = first; /* ... */
11342 newop->op_next = last->op_next; /* nextstate3 */
11343 newop->op_sibling = last->op_sibling;
11344 last->op_next = newop; /* listop */
11345 last->op_sibling = NULL;
11346 o->op_sibling = newop; /* ... */
11348 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11350 /* Ensure pushmark has this flag if padops do */
11351 if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
11352 o->op_next->op_flags |= OPf_MOD;
11358 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11359 to carry two labels. For now, take the easier option, and skip
11360 this optimisation if the first NEXTSTATE has a label. */
11361 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11362 OP *nextop = o->op_next;
11363 while (nextop && nextop->op_type == OP_NULL)
11364 nextop = nextop->op_next;
11366 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11367 COP *firstcop = (COP *)o;
11368 COP *secondcop = (COP *)nextop;
11369 /* We want the COP pointed to by o (and anything else) to
11370 become the next COP down the line. */
11371 cop_free(firstcop);
11373 firstcop->op_next = secondcop->op_next;
11375 /* Now steal all its pointers, and duplicate the other
11377 firstcop->cop_line = secondcop->cop_line;
11378 #ifdef USE_ITHREADS
11379 firstcop->cop_stashoff = secondcop->cop_stashoff;
11380 firstcop->cop_file = secondcop->cop_file;
11382 firstcop->cop_stash = secondcop->cop_stash;
11383 firstcop->cop_filegv = secondcop->cop_filegv;
11385 firstcop->cop_hints = secondcop->cop_hints;
11386 firstcop->cop_seq = secondcop->cop_seq;
11387 firstcop->cop_warnings = secondcop->cop_warnings;
11388 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11390 #ifdef USE_ITHREADS
11391 secondcop->cop_stashoff = 0;
11392 secondcop->cop_file = NULL;
11394 secondcop->cop_stash = NULL;
11395 secondcop->cop_filegv = NULL;
11397 secondcop->cop_warnings = NULL;
11398 secondcop->cop_hints_hash = NULL;
11400 /* If we use op_null(), and hence leave an ex-COP, some
11401 warnings are misreported. For example, the compile-time
11402 error in 'use strict; no strict refs;' */
11403 secondcop->op_type = OP_NULL;
11404 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11410 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11411 if (o->op_next->op_private & OPpTARGET_MY) {
11412 if (o->op_flags & OPf_STACKED) /* chained concats */
11413 break; /* ignore_optimization */
11415 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11416 o->op_targ = o->op_next->op_targ;
11417 o->op_next->op_targ = 0;
11418 o->op_private |= OPpTARGET_MY;
11421 op_null(o->op_next);
11425 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11426 break; /* Scalar stub must produce undef. List stub is noop */
11430 if (o->op_targ == OP_NEXTSTATE
11431 || o->op_targ == OP_DBSTATE)
11433 PL_curcop = ((COP*)o);
11435 /* XXX: We avoid setting op_seq here to prevent later calls
11436 to rpeep() from mistakenly concluding that optimisation
11437 has already occurred. This doesn't fix the real problem,
11438 though (See 20010220.007). AMS 20010719 */
11439 /* op_seq functionality is now replaced by op_opt */
11446 if (oldop && o->op_next) {
11447 oldop->op_next = o->op_next;
11455 /* Convert a series of PAD ops for my vars plus support into a
11456 * single padrange op. Basically
11458 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11460 * becomes, depending on circumstances, one of
11462 * padrange ----------------------------------> (list) -> rest
11463 * padrange --------------------------------------------> rest
11465 * where all the pad indexes are sequential and of the same type
11467 * We convert the pushmark into a padrange op, then skip
11468 * any other pad ops, and possibly some trailing ops.
11469 * Note that we don't null() the skipped ops, to make it
11470 * easier for Deparse to undo this optimisation (and none of
11471 * the skipped ops are holding any resourses). It also makes
11472 * it easier for find_uninit_var(), as it can just ignore
11473 * padrange, and examine the original pad ops.
11477 OP *followop = NULL; /* the op that will follow the padrange op */
11480 PADOFFSET base = 0; /* init only to stop compiler whining */
11481 U8 gimme = 0; /* init only to stop compiler whining */
11482 bool defav = 0; /* seen (...) = @_ */
11483 bool reuse = 0; /* reuse an existing padrange op */
11485 /* look for a pushmark -> gv[_] -> rv2av */
11491 if ( p->op_type == OP_GV
11492 && (gv = cGVOPx_gv(p))
11493 && GvNAMELEN_get(gv) == 1
11494 && *GvNAME_get(gv) == '_'
11495 && GvSTASH(gv) == PL_defstash
11496 && (rv2av = p->op_next)
11497 && rv2av->op_type == OP_RV2AV
11498 && !(rv2av->op_flags & OPf_REF)
11499 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11500 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11501 && o->op_sibling == rv2av /* these two for Deparse */
11502 && cUNOPx(rv2av)->op_first == p
11504 q = rv2av->op_next;
11505 if (q->op_type == OP_NULL)
11507 if (q->op_type == OP_PUSHMARK) {
11514 /* To allow Deparse to pessimise this, it needs to be able
11515 * to restore the pushmark's original op_next, which it
11516 * will assume to be the same as op_sibling. */
11517 if (o->op_next != o->op_sibling)
11522 /* scan for PAD ops */
11524 for (p = p->op_next; p; p = p->op_next) {
11525 if (p->op_type == OP_NULL)
11528 if (( p->op_type != OP_PADSV
11529 && p->op_type != OP_PADAV
11530 && p->op_type != OP_PADHV
11532 /* any private flag other than INTRO? e.g. STATE */
11533 || (p->op_private & ~OPpLVAL_INTRO)
11537 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11539 if ( p->op_type == OP_PADAV
11541 && p->op_next->op_type == OP_CONST
11542 && p->op_next->op_next
11543 && p->op_next->op_next->op_type == OP_AELEM
11547 /* for 1st padop, note what type it is and the range
11548 * start; for the others, check that it's the same type
11549 * and that the targs are contiguous */
11551 intro = (p->op_private & OPpLVAL_INTRO);
11553 gimme = (p->op_flags & OPf_WANT);
11556 if ((p->op_private & OPpLVAL_INTRO) != intro)
11558 /* Note that you'd normally expect targs to be
11559 * contiguous in my($a,$b,$c), but that's not the case
11560 * when external modules start doing things, e.g.
11561 i* Function::Parameters */
11562 if (p->op_targ != base + count)
11564 assert(p->op_targ == base + count);
11565 /* all the padops should be in the same context */
11566 if (gimme != (p->op_flags & OPf_WANT))
11570 /* for AV, HV, only when we're not flattening */
11571 if ( p->op_type != OP_PADSV
11572 && gimme != OPf_WANT_VOID
11573 && !(p->op_flags & OPf_REF)
11577 if (count >= OPpPADRANGE_COUNTMASK)
11580 /* there's a biggest base we can fit into a
11581 * SAVEt_CLEARPADRANGE in pp_padrange */
11582 if (intro && base >
11583 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11586 /* Success! We've got another valid pad op to optimise away */
11588 followop = p->op_next;
11594 /* pp_padrange in specifically compile-time void context
11595 * skips pushing a mark and lexicals; in all other contexts
11596 * (including unknown till runtime) it pushes a mark and the
11597 * lexicals. We must be very careful then, that the ops we
11598 * optimise away would have exactly the same effect as the
11600 * In particular in void context, we can only optimise to
11601 * a padrange if see see the complete sequence
11602 * pushmark, pad*v, ...., list, nextstate
11603 * which has the net effect of of leaving the stack empty
11604 * (for now we leave the nextstate in the execution chain, for
11605 * its other side-effects).
11608 if (gimme == OPf_WANT_VOID) {
11609 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11610 && gimme == (followop->op_flags & OPf_WANT)
11611 && ( followop->op_next->op_type == OP_NEXTSTATE
11612 || followop->op_next->op_type == OP_DBSTATE))
11614 followop = followop->op_next; /* skip OP_LIST */
11616 /* consolidate two successive my(...);'s */
11619 && oldoldop->op_type == OP_PADRANGE
11620 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11621 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11622 && !(oldoldop->op_flags & OPf_SPECIAL)
11625 assert(oldoldop->op_next == oldop);
11626 assert( oldop->op_type == OP_NEXTSTATE
11627 || oldop->op_type == OP_DBSTATE);
11628 assert(oldop->op_next == o);
11631 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11633 /* Do not assume pad offsets for $c and $d are con-
11638 if ( oldoldop->op_targ + old_count == base
11639 && old_count < OPpPADRANGE_COUNTMASK - count) {
11640 base = oldoldop->op_targ;
11641 count += old_count;
11646 /* if there's any immediately following singleton
11647 * my var's; then swallow them and the associated
11649 * my ($a,$b); my $c; my $d;
11651 * my ($a,$b,$c,$d);
11654 while ( ((p = followop->op_next))
11655 && ( p->op_type == OP_PADSV
11656 || p->op_type == OP_PADAV
11657 || p->op_type == OP_PADHV)
11658 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11659 && (p->op_private & OPpLVAL_INTRO) == intro
11660 && !(p->op_private & ~OPpLVAL_INTRO)
11662 && ( p->op_next->op_type == OP_NEXTSTATE
11663 || p->op_next->op_type == OP_DBSTATE)
11664 && count < OPpPADRANGE_COUNTMASK
11665 && base + count == p->op_targ
11668 followop = p->op_next;
11676 assert(oldoldop->op_type == OP_PADRANGE);
11677 oldoldop->op_next = followop;
11678 oldoldop->op_private = (intro | count);
11684 /* Convert the pushmark into a padrange.
11685 * To make Deparse easier, we guarantee that a padrange was
11686 * *always* formerly a pushmark */
11687 assert(o->op_type == OP_PUSHMARK);
11688 o->op_next = followop;
11689 o->op_type = OP_PADRANGE;
11690 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11692 /* bit 7: INTRO; bit 6..0: count */
11693 o->op_private = (intro | count);
11694 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11695 | gimme | (defav ? OPf_SPECIAL : 0));
11702 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11703 OP* const pop = (o->op_type == OP_PADAV) ?
11704 o->op_next : o->op_next->op_next;
11706 if (pop && pop->op_type == OP_CONST &&
11707 ((PL_op = pop->op_next)) &&
11708 pop->op_next->op_type == OP_AELEM &&
11709 !(pop->op_next->op_private &
11710 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11711 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11714 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11715 no_bareword_allowed(pop);
11716 if (o->op_type == OP_GV)
11717 op_null(o->op_next);
11718 op_null(pop->op_next);
11720 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11721 o->op_next = pop->op_next->op_next;
11722 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11723 o->op_private = (U8)i;
11724 if (o->op_type == OP_GV) {
11727 o->op_type = OP_AELEMFAST;
11730 o->op_type = OP_AELEMFAST_LEX;
11735 if (o->op_next->op_type == OP_RV2SV) {
11736 if (!(o->op_next->op_private & OPpDEREF)) {
11737 op_null(o->op_next);
11738 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11740 o->op_next = o->op_next->op_next;
11741 o->op_type = OP_GVSV;
11742 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11745 else if (o->op_next->op_type == OP_READLINE
11746 && o->op_next->op_next->op_type == OP_CONCAT
11747 && (o->op_next->op_next->op_flags & OPf_STACKED))
11749 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11750 o->op_type = OP_RCATLINE;
11751 o->op_flags |= OPf_STACKED;
11752 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11753 op_null(o->op_next->op_next);
11754 op_null(o->op_next);
11763 #define HV_OR_SCALARHV(op) \
11764 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11766 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11767 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11768 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11769 ? cUNOPx(op)->op_first \
11773 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11774 fop->op_private |= OPpTRUEBOOL;
11780 fop = cLOGOP->op_first;
11781 sop = fop->op_sibling;
11782 while (cLOGOP->op_other->op_type == OP_NULL)
11783 cLOGOP->op_other = cLOGOP->op_other->op_next;
11784 while (o->op_next && ( o->op_type == o->op_next->op_type
11785 || o->op_next->op_type == OP_NULL))
11786 o->op_next = o->op_next->op_next;
11788 /* if we're an OR and our next is a AND in void context, we'll
11789 follow it's op_other on short circuit, same for reverse.
11790 We can't do this with OP_DOR since if it's true, its return
11791 value is the underlying value which must be evaluated
11795 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11796 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11798 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11800 o->op_next = ((LOGOP*)o->op_next)->op_other;
11802 DEFER(cLOGOP->op_other);
11805 fop = HV_OR_SCALARHV(fop);
11806 if (sop) sop = HV_OR_SCALARHV(sop);
11811 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11812 while (nop && nop->op_next) {
11813 switch (nop->op_next->op_type) {
11818 lop = nop = nop->op_next;
11821 nop = nop->op_next;
11830 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11831 || o->op_type == OP_AND )
11832 fop->op_private |= OPpTRUEBOOL;
11833 else if (!(lop->op_flags & OPf_WANT))
11834 fop->op_private |= OPpMAYBE_TRUEBOOL;
11836 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11838 sop->op_private |= OPpTRUEBOOL;
11845 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11846 fop->op_private |= OPpTRUEBOOL;
11847 #undef HV_OR_SCALARHV
11858 while (cLOGOP->op_other->op_type == OP_NULL)
11859 cLOGOP->op_other = cLOGOP->op_other->op_next;
11860 DEFER(cLOGOP->op_other);
11865 while (cLOOP->op_redoop->op_type == OP_NULL)
11866 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11867 while (cLOOP->op_nextop->op_type == OP_NULL)
11868 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11869 while (cLOOP->op_lastop->op_type == OP_NULL)
11870 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11871 /* a while(1) loop doesn't have an op_next that escapes the
11872 * loop, so we have to explicitly follow the op_lastop to
11873 * process the rest of the code */
11874 DEFER(cLOOP->op_lastop);
11878 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11879 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11880 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11881 cPMOP->op_pmstashstartu.op_pmreplstart
11882 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11883 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11889 if (o->op_flags & OPf_STACKED) {
11891 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11892 if (kid->op_type == OP_SCOPE
11893 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11894 DEFER(kLISTOP->op_first);
11897 /* check that RHS of sort is a single plain array */
11898 oright = cUNOPo->op_first;
11899 if (!oright || oright->op_type != OP_PUSHMARK)
11902 if (o->op_private & OPpSORT_INPLACE)
11905 /* reverse sort ... can be optimised. */
11906 if (!cUNOPo->op_sibling) {
11907 /* Nothing follows us on the list. */
11908 OP * const reverse = o->op_next;
11910 if (reverse->op_type == OP_REVERSE &&
11911 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11912 OP * const pushmark = cUNOPx(reverse)->op_first;
11913 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11914 && (cUNOPx(pushmark)->op_sibling == o)) {
11915 /* reverse -> pushmark -> sort */
11916 o->op_private |= OPpSORT_REVERSE;
11918 pushmark->op_next = oright->op_next;
11928 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11930 LISTOP *enter, *exlist;
11932 if (o->op_private & OPpSORT_INPLACE)
11935 enter = (LISTOP *) o->op_next;
11938 if (enter->op_type == OP_NULL) {
11939 enter = (LISTOP *) enter->op_next;
11943 /* for $a (...) will have OP_GV then OP_RV2GV here.
11944 for (...) just has an OP_GV. */
11945 if (enter->op_type == OP_GV) {
11946 gvop = (OP *) enter;
11947 enter = (LISTOP *) enter->op_next;
11950 if (enter->op_type == OP_RV2GV) {
11951 enter = (LISTOP *) enter->op_next;
11957 if (enter->op_type != OP_ENTERITER)
11960 iter = enter->op_next;
11961 if (!iter || iter->op_type != OP_ITER)
11964 expushmark = enter->op_first;
11965 if (!expushmark || expushmark->op_type != OP_NULL
11966 || expushmark->op_targ != OP_PUSHMARK)
11969 exlist = (LISTOP *) expushmark->op_sibling;
11970 if (!exlist || exlist->op_type != OP_NULL
11971 || exlist->op_targ != OP_LIST)
11974 if (exlist->op_last != o) {
11975 /* Mmm. Was expecting to point back to this op. */
11978 theirmark = exlist->op_first;
11979 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11982 if (theirmark->op_sibling != o) {
11983 /* There's something between the mark and the reverse, eg
11984 for (1, reverse (...))
11989 ourmark = ((LISTOP *)o)->op_first;
11990 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11993 ourlast = ((LISTOP *)o)->op_last;
11994 if (!ourlast || ourlast->op_next != o)
11997 rv2av = ourmark->op_sibling;
11998 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11999 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12000 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12001 /* We're just reversing a single array. */
12002 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12003 enter->op_flags |= OPf_STACKED;
12006 /* We don't have control over who points to theirmark, so sacrifice
12008 theirmark->op_next = ourmark->op_next;
12009 theirmark->op_flags = ourmark->op_flags;
12010 ourlast->op_next = gvop ? gvop : (OP *) enter;
12013 enter->op_private |= OPpITER_REVERSED;
12014 iter->op_private |= OPpITER_REVERSED;
12021 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12022 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12027 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
12029 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12031 sv = newRV((SV *)PL_compcv);
12035 o->op_type = OP_CONST;
12036 o->op_ppaddr = PL_ppaddr[OP_CONST];
12037 o->op_flags |= OPf_SPECIAL;
12038 cSVOPo->op_sv = sv;
12043 if (OP_GIMME(o,0) == G_VOID) {
12044 OP *right = cBINOP->op_first;
12046 OP *left = right->op_sibling;
12047 if (left->op_type == OP_SUBSTR
12048 && (left->op_private & 7) < 4) {
12050 cBINOP->op_first = left;
12051 right->op_sibling =
12052 cBINOPx(left)->op_first->op_sibling;
12053 cBINOPx(left)->op_first->op_sibling = right;
12054 left->op_private |= OPpSUBSTR_REPL_FIRST;
12056 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12063 Perl_cpeep_t cpeep =
12064 XopENTRYCUSTOM(o, xop_peep);
12066 cpeep(aTHX_ o, oldop);
12078 Perl_peep(pTHX_ OP *o)
12084 =head1 Custom Operators
12086 =for apidoc Ao||custom_op_xop
12087 Return the XOP structure for a given custom op. This macro should be
12088 considered internal to OP_NAME and the other access macros: use them instead.
12089 This macro does call a function. Prior
12090 to 5.19.6, this was implemented as a
12097 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12103 static const XOP xop_null = { 0, 0, 0, 0, 0 };
12105 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12106 assert(o->op_type == OP_CUSTOM);
12108 /* This is wrong. It assumes a function pointer can be cast to IV,
12109 * which isn't guaranteed, but this is what the old custom OP code
12110 * did. In principle it should be safer to Copy the bytes of the
12111 * pointer into a PV: since the new interface is hidden behind
12112 * functions, this can be changed later if necessary. */
12113 /* Change custom_op_xop if this ever happens */
12114 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12117 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12119 /* assume noone will have just registered a desc */
12120 if (!he && PL_custom_op_names &&
12121 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12126 /* XXX does all this need to be shared mem? */
12127 Newxz(xop, 1, XOP);
12128 pv = SvPV(HeVAL(he), l);
12129 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12130 if (PL_custom_op_descs &&
12131 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12133 pv = SvPV(HeVAL(he), l);
12134 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12136 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12140 xop = (XOP *)&xop_null;
12142 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12146 if(field == XOPe_xop_ptr) {
12149 const U32 flags = XopFLAGS(xop);
12150 if(flags & field) {
12152 case XOPe_xop_name:
12153 any.xop_name = xop->xop_name;
12155 case XOPe_xop_desc:
12156 any.xop_desc = xop->xop_desc;
12158 case XOPe_xop_class:
12159 any.xop_class = xop->xop_class;
12161 case XOPe_xop_peep:
12162 any.xop_peep = xop->xop_peep;
12170 case XOPe_xop_name:
12171 any.xop_name = XOPd_xop_name;
12173 case XOPe_xop_desc:
12174 any.xop_desc = XOPd_xop_desc;
12176 case XOPe_xop_class:
12177 any.xop_class = XOPd_xop_class;
12179 case XOPe_xop_peep:
12180 any.xop_peep = XOPd_xop_peep;
12193 =for apidoc Ao||custom_op_register
12194 Register a custom op. See L<perlguts/"Custom Operators">.
12200 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12204 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12206 /* see the comment in custom_op_xop */
12207 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12209 if (!PL_custom_ops)
12210 PL_custom_ops = newHV();
12212 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12213 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12217 =head1 Functions in file op.c
12219 =for apidoc core_prototype
12220 This function assigns the prototype of the named core function to C<sv>, or
12221 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12222 NULL if the core function has no prototype. C<code> is a code as returned
12223 by C<keyword()>. It must not be equal to 0.
12229 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12232 int i = 0, n = 0, seen_question = 0, defgv = 0;
12234 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12235 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12236 bool nullret = FALSE;
12238 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12242 if (!sv) sv = sv_newmortal();
12244 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12246 switch (code < 0 ? -code : code) {
12247 case KEY_and : case KEY_chop: case KEY_chomp:
12248 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12249 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12250 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12251 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12252 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12253 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12254 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12255 case KEY_x : case KEY_xor :
12256 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12257 case KEY_glob: retsetpvs("_;", OP_GLOB);
12258 case KEY_keys: retsetpvs("+", OP_KEYS);
12259 case KEY_values: retsetpvs("+", OP_VALUES);
12260 case KEY_each: retsetpvs("+", OP_EACH);
12261 case KEY_push: retsetpvs("+@", OP_PUSH);
12262 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12263 case KEY_pop: retsetpvs(";+", OP_POP);
12264 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12265 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12267 retsetpvs("+;$$@", OP_SPLICE);
12268 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12270 case KEY_evalbytes:
12271 name = "entereval"; break;
12279 while (i < MAXO) { /* The slow way. */
12280 if (strEQ(name, PL_op_name[i])
12281 || strEQ(name, PL_op_desc[i]))
12283 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12290 defgv = PL_opargs[i] & OA_DEFGV;
12291 oa = PL_opargs[i] >> OASHIFT;
12293 if (oa & OA_OPTIONAL && !seen_question && (
12294 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12299 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12300 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12301 /* But globs are already references (kinda) */
12302 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12306 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12307 && !scalar_mod_type(NULL, i)) {
12312 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12316 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12317 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12318 str[n-1] = '_'; defgv = 0;
12322 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12324 sv_setpvn(sv, str, n - 1);
12325 if (opnum) *opnum = i;
12330 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12333 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12336 PERL_ARGS_ASSERT_CORESUB_OP;
12340 return op_append_elem(OP_LINESEQ,
12343 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12347 case OP_SELECT: /* which represents OP_SSELECT as well */
12352 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12353 newSVOP(OP_CONST, 0, newSVuv(1))
12355 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12357 coresub_op(coreargssv, 0, OP_SELECT)
12361 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12363 return op_append_elem(
12366 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12367 ? OPpOFFBYONE << 8 : 0)
12369 case OA_BASEOP_OR_UNOP:
12370 if (opnum == OP_ENTEREVAL) {
12371 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12372 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12374 else o = newUNOP(opnum,0,argop);
12375 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12378 if (is_handle_constructor(o, 1))
12379 argop->op_private |= OPpCOREARGS_DEREF1;
12380 if (scalar_mod_type(NULL, opnum))
12381 argop->op_private |= OPpCOREARGS_SCALARMOD;
12385 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12386 if (is_handle_constructor(o, 2))
12387 argop->op_private |= OPpCOREARGS_DEREF2;
12388 if (opnum == OP_SUBSTR) {
12389 o->op_private |= OPpMAYBE_LVSUB;
12398 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12399 SV * const *new_const_svp)
12401 const char *hvname;
12402 bool is_const = !!CvCONST(old_cv);
12403 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12405 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12407 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12409 /* They are 2 constant subroutines generated from
12410 the same constant. This probably means that
12411 they are really the "same" proxy subroutine
12412 instantiated in 2 places. Most likely this is
12413 when a constant is exported twice. Don't warn.
12416 (ckWARN(WARN_REDEFINE)
12418 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12419 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12420 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12421 strEQ(hvname, "autouse"))
12425 && ckWARN_d(WARN_REDEFINE)
12426 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12429 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12431 ? "Constant subroutine %"SVf" redefined"
12432 : "Subroutine %"SVf" redefined",
12437 =head1 Hook manipulation
12439 These functions provide convenient and thread-safe means of manipulating
12446 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12448 Puts a C function into the chain of check functions for a specified op
12449 type. This is the preferred way to manipulate the L</PL_check> array.
12450 I<opcode> specifies which type of op is to be affected. I<new_checker>
12451 is a pointer to the C function that is to be added to that opcode's
12452 check chain, and I<old_checker_p> points to the storage location where a
12453 pointer to the next function in the chain will be stored. The value of
12454 I<new_pointer> is written into the L</PL_check> array, while the value
12455 previously stored there is written to I<*old_checker_p>.
12457 The function should be defined like this:
12459 static OP *new_checker(pTHX_ OP *op) { ... }
12461 It is intended to be called in this manner:
12463 new_checker(aTHX_ op)
12465 I<old_checker_p> should be defined like this:
12467 static Perl_check_t old_checker_p;
12469 L</PL_check> is global to an entire process, and a module wishing to
12470 hook op checking may find itself invoked more than once per process,
12471 typically in different threads. To handle that situation, this function
12472 is idempotent. The location I<*old_checker_p> must initially (once
12473 per process) contain a null pointer. A C variable of static duration
12474 (declared at file scope, typically also marked C<static> to give
12475 it internal linkage) will be implicitly initialised appropriately,
12476 if it does not have an explicit initialiser. This function will only
12477 actually modify the check chain if it finds I<*old_checker_p> to be null.
12478 This function is also thread safe on the small scale. It uses appropriate
12479 locking to avoid race conditions in accessing L</PL_check>.
12481 When this function is called, the function referenced by I<new_checker>
12482 must be ready to be called, except for I<*old_checker_p> being unfilled.
12483 In a threading situation, I<new_checker> may be called immediately,
12484 even before this function has returned. I<*old_checker_p> will always
12485 be appropriately set before I<new_checker> is called. If I<new_checker>
12486 decides not to do anything special with an op that it is given (which
12487 is the usual case for most uses of op check hooking), it must chain the
12488 check function referenced by I<*old_checker_p>.
12490 If you want to influence compilation of calls to a specific subroutine,
12491 then use L</cv_set_call_checker> rather than hooking checking of all
12498 Perl_wrap_op_checker(pTHX_ Optype opcode,
12499 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12503 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12504 if (*old_checker_p) return;
12505 OP_CHECK_MUTEX_LOCK;
12506 if (!*old_checker_p) {
12507 *old_checker_p = PL_check[opcode];
12508 PL_check[opcode] = new_checker;
12510 OP_CHECK_MUTEX_UNLOCK;
12515 /* Efficient sub that returns a constant scalar value. */
12517 const_sv_xsub(pTHX_ CV* cv)
12521 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12522 PERL_UNUSED_ARG(items);
12532 const_av_xsub(pTHX_ CV* cv)
12536 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12544 if (SvRMAGICAL(av))
12545 Perl_croak(aTHX_ "Magical list constants are not supported");
12546 if (GIMME_V != G_ARRAY) {
12548 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12551 EXTEND(SP, AvFILLp(av)+1);
12552 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12553 XSRETURN(AvFILLp(av)+1);
12558 * c-indentation-style: bsd
12559 * c-basic-offset: 4
12560 * indent-tabs-mode: nil
12563 * ex: set ts=8 sts=4 sw=4 et: