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 Perl_op_free(pTHX_ OP *o)
681 /* Though ops may be freed twice, freeing the op after its slab is a
683 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
684 /* During the forced freeing of ops after compilation failure, kidops
685 may be freed before their parents. */
686 if (!o || o->op_type == OP_FREED)
690 if (o->op_private & OPpREFCOUNTED) {
701 refcnt = OpREFCNT_dec(o);
704 /* Need to find and remove any pattern match ops from the list
705 we maintain for reset(). */
706 find_and_forget_pmops(o);
716 /* Call the op_free hook if it has been set. Do it now so that it's called
717 * at the right time for refcounted ops, but still before all of the kids
721 if (o->op_flags & OPf_KIDS) {
723 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
724 nextkid = kid->op_sibling; /* Get before next freeing kid */
729 type = (OPCODE)o->op_targ;
732 Slab_to_rw(OpSLAB(o));
734 /* COP* is not cleared by op_clear() so that we may track line
735 * numbers etc even after null() */
736 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
742 #ifdef DEBUG_LEAKING_SCALARS
749 Perl_op_clear(pTHX_ OP *o)
754 PERL_ARGS_ASSERT_OP_CLEAR;
757 mad_free(o->op_madprop);
762 switch (o->op_type) {
763 case OP_NULL: /* Was holding old type, if any. */
764 if (PL_madskills && o->op_targ != OP_NULL) {
765 o->op_type = (Optype)o->op_targ;
770 case OP_ENTEREVAL: /* Was holding hints. */
774 if (!(o->op_flags & OPf_REF)
775 || (PL_check[o->op_type] != Perl_ck_ftst))
782 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
787 /* It's possible during global destruction that the GV is freed
788 before the optree. Whilst the SvREFCNT_inc is happy to bump from
789 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790 will trigger an assertion failure, because the entry to sv_clear
791 checks that the scalar is not already freed. A check of for
792 !SvIS_FREED(gv) turns out to be invalid, because during global
793 destruction the reference count can be forced down to zero
794 (with SVf_BREAK set). In which case raising to 1 and then
795 dropping to 0 triggers cleanup before it should happen. I
796 *think* that this might actually be a general, systematic,
797 weakness of the whole idea of SVf_BREAK, in that code *is*
798 allowed to raise and lower references during global destruction,
799 so any *valid* code that happens to do this during global
800 destruction might well trigger premature cleanup. */
801 bool still_valid = gv && SvREFCNT(gv);
804 SvREFCNT_inc_simple_void(gv);
806 if (cPADOPo->op_padix > 0) {
807 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
808 * may still exist on the pad */
809 pad_swipe(cPADOPo->op_padix, TRUE);
810 cPADOPo->op_padix = 0;
813 SvREFCNT_dec(cSVOPo->op_sv);
814 cSVOPo->op_sv = NULL;
817 int try_downgrade = SvREFCNT(gv) == 2;
820 gv_try_downgrade(gv);
824 case OP_METHOD_NAMED:
827 SvREFCNT_dec(cSVOPo->op_sv);
828 cSVOPo->op_sv = NULL;
831 Even if op_clear does a pad_free for the target of the op,
832 pad_free doesn't actually remove the sv that exists in the pad;
833 instead it lives on. This results in that it could be reused as
834 a target later on when the pad was reallocated.
837 pad_swipe(o->op_targ,1);
847 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
853 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
855 if (cPADOPo->op_padix > 0) {
856 pad_swipe(cPADOPo->op_padix, TRUE);
857 cPADOPo->op_padix = 0;
860 SvREFCNT_dec(cSVOPo->op_sv);
861 cSVOPo->op_sv = NULL;
865 PerlMemShared_free(cPVOPo->op_pv);
866 cPVOPo->op_pv = NULL;
870 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
874 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
875 /* No GvIN_PAD_off here, because other references may still
876 * exist on the pad */
877 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
880 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
886 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
887 op_free(cPMOPo->op_code_list);
888 cPMOPo->op_code_list = NULL;
890 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
891 /* we use the same protection as the "SAFE" version of the PM_ macros
892 * here since sv_clean_all might release some PMOPs
893 * after PL_regex_padav has been cleared
894 * and the clearing of PL_regex_padav needs to
895 * happen before sv_clean_all
898 if(PL_regex_pad) { /* We could be in destruction */
899 const IV offset = (cPMOPo)->op_pmoffset;
900 ReREFCNT_dec(PM_GETRE(cPMOPo));
901 PL_regex_pad[offset] = &PL_sv_undef;
902 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
906 ReREFCNT_dec(PM_GETRE(cPMOPo));
907 PM_SETRE(cPMOPo, NULL);
913 if (o->op_targ > 0) {
914 pad_free(o->op_targ);
920 S_cop_free(pTHX_ COP* cop)
922 PERL_ARGS_ASSERT_COP_FREE;
925 if (! specialWARN(cop->cop_warnings))
926 PerlMemShared_free(cop->cop_warnings);
927 cophh_free(CopHINTHASH_get(cop));
928 if (PL_curcop == cop)
933 S_forget_pmop(pTHX_ PMOP *const o
936 HV * const pmstash = PmopSTASH(o);
938 PERL_ARGS_ASSERT_FORGET_PMOP;
940 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
941 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
943 PMOP **const array = (PMOP**) mg->mg_ptr;
944 U32 count = mg->mg_len / sizeof(PMOP**);
949 /* Found it. Move the entry at the end to overwrite it. */
950 array[i] = array[--count];
951 mg->mg_len = count * sizeof(PMOP**);
952 /* Could realloc smaller at this point always, but probably
953 not worth it. Probably worth free()ing if we're the
956 Safefree(mg->mg_ptr);
969 S_find_and_forget_pmops(pTHX_ OP *o)
971 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
973 if (o->op_flags & OPf_KIDS) {
974 OP *kid = cUNOPo->op_first;
976 switch (kid->op_type) {
981 forget_pmop((PMOP*)kid);
983 find_and_forget_pmops(kid);
984 kid = kid->op_sibling;
990 Perl_op_null(pTHX_ OP *o)
994 PERL_ARGS_ASSERT_OP_NULL;
996 if (o->op_type == OP_NULL)
1000 o->op_targ = o->op_type;
1001 o->op_type = OP_NULL;
1002 o->op_ppaddr = PL_ppaddr[OP_NULL];
1006 Perl_op_refcnt_lock(pTHX)
1009 PERL_UNUSED_CONTEXT;
1014 Perl_op_refcnt_unlock(pTHX)
1017 PERL_UNUSED_CONTEXT;
1021 /* Contextualizers */
1024 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1026 Applies a syntactic context to an op tree representing an expression.
1027 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1028 or C<G_VOID> to specify the context to apply. The modified op tree
1035 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1037 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1039 case G_SCALAR: return scalar(o);
1040 case G_ARRAY: return list(o);
1041 case G_VOID: return scalarvoid(o);
1043 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1050 =head1 Optree Manipulation Functions
1052 =for apidoc Am|OP*|op_linklist|OP *o
1053 This function is the implementation of the L</LINKLIST> macro. It should
1054 not be called directly.
1060 Perl_op_linklist(pTHX_ OP *o)
1064 PERL_ARGS_ASSERT_OP_LINKLIST;
1069 /* establish postfix order */
1070 first = cUNOPo->op_first;
1073 o->op_next = LINKLIST(first);
1076 if (kid->op_sibling) {
1077 kid->op_next = LINKLIST(kid->op_sibling);
1078 kid = kid->op_sibling;
1092 S_scalarkids(pTHX_ OP *o)
1094 if (o && o->op_flags & OPf_KIDS) {
1096 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1103 S_scalarboolean(pTHX_ OP *o)
1107 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1109 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1110 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1111 if (ckWARN(WARN_SYNTAX)) {
1112 const line_t oldline = CopLINE(PL_curcop);
1114 if (PL_parser && PL_parser->copline != NOLINE) {
1115 /* This ensures that warnings are reported at the first line
1116 of the conditional, not the last. */
1117 CopLINE_set(PL_curcop, PL_parser->copline);
1119 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1120 CopLINE_set(PL_curcop, oldline);
1127 S_op_varname(pTHX_ const OP *o)
1130 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1131 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1133 const char funny = o->op_type == OP_PADAV
1134 || o->op_type == OP_RV2AV ? '@' : '%';
1135 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1137 if (cUNOPo->op_first->op_type != OP_GV
1138 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1140 return varname(gv, funny, 0, NULL, 0, 1);
1143 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1148 S_scalar_slice_warning(pTHX_ const OP *o)
1152 o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '{' : '[';
1154 o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '}' : ']';
1156 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ? '@' : '%';
1159 const char *key = NULL;
1161 if (!(o->op_private & OPpSLICEWARNING))
1163 if (PL_parser && PL_parser->error_count)
1164 /* This warning can be nonsensical when there is a syntax error. */
1167 kid = cLISTOPo->op_first;
1168 kid = kid->op_sibling; /* get past pushmark */
1169 /* weed out false positives: any ops that can return lists */
1170 switch (kid->op_type) {
1198 assert(kid->op_sibling);
1199 name = S_op_varname(aTHX_ kid->op_sibling);
1200 if (!name) /* XS module fiddling with the op tree */
1202 if (kid->op_type == OP_CONST) {
1204 if (SvPOK(kSVOP_sv)) {
1206 keysv = sv_newmortal();
1207 pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1208 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1210 else if (!SvOK(keysv))
1214 assert(SvPOK(name));
1215 sv_chop(name,SvPVX(name)+1);
1217 /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
1218 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1219 "Scalar value %c%"SVf"%c%s%c better written as $%"SVf
1221 funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1222 lbrack, key, rbrack);
1224 /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
1225 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1226 "Scalar value %c%"SVf"%c%"SVf"%c better written as $%"
1228 funny, SVfARG(name), lbrack, keysv, rbrack,
1229 SVfARG(name), lbrack, keysv, rbrack);
1233 Perl_scalar(pTHX_ OP *o)
1238 /* assumes no premature commitment */
1239 if (!o || (PL_parser && PL_parser->error_count)
1240 || (o->op_flags & OPf_WANT)
1241 || o->op_type == OP_RETURN)
1246 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1248 switch (o->op_type) {
1250 scalar(cBINOPo->op_first);
1255 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1265 if (o->op_flags & OPf_KIDS) {
1266 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1272 kid = cLISTOPo->op_first;
1274 kid = kid->op_sibling;
1277 OP *sib = kid->op_sibling;
1278 if (sib && kid->op_type != OP_LEAVEWHEN)
1284 PL_curcop = &PL_compiling;
1289 kid = cLISTOPo->op_first;
1292 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1296 S_scalar_slice_warning(aTHX_ o);
1302 Perl_scalarvoid(pTHX_ OP *o)
1306 SV *useless_sv = NULL;
1307 const char* useless = NULL;
1311 PERL_ARGS_ASSERT_SCALARVOID;
1313 /* trailing mad null ops don't count as "there" for void processing */
1315 o->op_type != OP_NULL &&
1317 o->op_sibling->op_type == OP_NULL)
1320 for (sib = o->op_sibling;
1321 sib && sib->op_type == OP_NULL;
1322 sib = sib->op_sibling) ;
1328 if (o->op_type == OP_NEXTSTATE
1329 || o->op_type == OP_DBSTATE
1330 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1331 || o->op_targ == OP_DBSTATE)))
1332 PL_curcop = (COP*)o; /* for warning below */
1334 /* assumes no premature commitment */
1335 want = o->op_flags & OPf_WANT;
1336 if ((want && want != OPf_WANT_SCALAR)
1337 || (PL_parser && PL_parser->error_count)
1338 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1343 if ((o->op_private & OPpTARGET_MY)
1344 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1346 return scalar(o); /* As if inside SASSIGN */
1349 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1351 switch (o->op_type) {
1353 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1357 if (o->op_flags & OPf_STACKED)
1361 if (o->op_private == 4)
1386 case OP_AELEMFAST_LEX:
1407 case OP_GETSOCKNAME:
1408 case OP_GETPEERNAME:
1413 case OP_GETPRIORITY:
1438 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1439 /* Otherwise it's "Useless use of grep iterator" */
1440 useless = OP_DESC(o);
1444 kid = cLISTOPo->op_first;
1445 if (kid && kid->op_type == OP_PUSHRE
1447 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1449 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1451 useless = OP_DESC(o);
1455 kid = cUNOPo->op_first;
1456 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1457 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1460 useless = "negative pattern binding (!~)";
1464 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1465 useless = "non-destructive substitution (s///r)";
1469 useless = "non-destructive transliteration (tr///r)";
1476 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1477 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1478 useless = "a variable";
1483 if (cSVOPo->op_private & OPpCONST_STRICT)
1484 no_bareword_allowed(o);
1486 if (ckWARN(WARN_VOID)) {
1487 /* don't warn on optimised away booleans, eg
1488 * use constant Foo, 5; Foo || print; */
1489 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1491 /* the constants 0 and 1 are permitted as they are
1492 conventionally used as dummies in constructs like
1493 1 while some_condition_with_side_effects; */
1494 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1496 else if (SvPOK(sv)) {
1497 SV * const dsv = newSVpvs("");
1499 = Perl_newSVpvf(aTHX_
1501 pv_pretty(dsv, SvPVX_const(sv),
1502 SvCUR(sv), 32, NULL, NULL,
1504 | PERL_PV_ESCAPE_NOCLEAR
1505 | PERL_PV_ESCAPE_UNI_DETECT));
1506 SvREFCNT_dec_NN(dsv);
1508 else if (SvOK(sv)) {
1509 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1512 useless = "a constant (undef)";
1515 op_null(o); /* don't execute or even remember it */
1519 o->op_type = OP_PREINC; /* pre-increment is faster */
1520 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1524 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1525 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1529 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1530 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1534 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1535 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1540 UNOP *refgen, *rv2cv;
1543 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1546 rv2gv = ((BINOP *)o)->op_last;
1547 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1550 refgen = (UNOP *)((BINOP *)o)->op_first;
1552 if (!refgen || refgen->op_type != OP_REFGEN)
1555 exlist = (LISTOP *)refgen->op_first;
1556 if (!exlist || exlist->op_type != OP_NULL
1557 || exlist->op_targ != OP_LIST)
1560 if (exlist->op_first->op_type != OP_PUSHMARK)
1563 rv2cv = (UNOP*)exlist->op_last;
1565 if (rv2cv->op_type != OP_RV2CV)
1568 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1569 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1570 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1572 o->op_private |= OPpASSIGN_CV_TO_GV;
1573 rv2gv->op_private |= OPpDONT_INIT_GV;
1574 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1586 kid = cLOGOPo->op_first;
1587 if (kid->op_type == OP_NOT
1588 && (kid->op_flags & OPf_KIDS)
1590 if (o->op_type == OP_AND) {
1592 o->op_ppaddr = PL_ppaddr[OP_OR];
1594 o->op_type = OP_AND;
1595 o->op_ppaddr = PL_ppaddr[OP_AND];
1604 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1609 if (o->op_flags & OPf_STACKED)
1616 if (!(o->op_flags & OPf_KIDS))
1627 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1638 /* mortalise it, in case warnings are fatal. */
1639 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1640 "Useless use of %"SVf" in void context",
1641 sv_2mortal(useless_sv));
1644 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1645 "Useless use of %s in void context",
1652 S_listkids(pTHX_ OP *o)
1654 if (o && o->op_flags & OPf_KIDS) {
1656 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1663 Perl_list(pTHX_ OP *o)
1668 /* assumes no premature commitment */
1669 if (!o || (o->op_flags & OPf_WANT)
1670 || (PL_parser && PL_parser->error_count)
1671 || o->op_type == OP_RETURN)
1676 if ((o->op_private & OPpTARGET_MY)
1677 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1679 return o; /* As if inside SASSIGN */
1682 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1684 switch (o->op_type) {
1687 list(cBINOPo->op_first);
1692 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1700 if (!(o->op_flags & OPf_KIDS))
1702 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1703 list(cBINOPo->op_first);
1704 return gen_constant_list(o);
1711 kid = cLISTOPo->op_first;
1713 kid = kid->op_sibling;
1716 OP *sib = kid->op_sibling;
1717 if (sib && kid->op_type != OP_LEAVEWHEN)
1723 PL_curcop = &PL_compiling;
1727 kid = cLISTOPo->op_first;
1734 S_scalarseq(pTHX_ OP *o)
1738 const OPCODE type = o->op_type;
1740 if (type == OP_LINESEQ || type == OP_SCOPE ||
1741 type == OP_LEAVE || type == OP_LEAVETRY)
1744 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1745 if (kid->op_sibling) {
1749 PL_curcop = &PL_compiling;
1751 o->op_flags &= ~OPf_PARENS;
1752 if (PL_hints & HINT_BLOCK_SCOPE)
1753 o->op_flags |= OPf_PARENS;
1756 o = newOP(OP_STUB, 0);
1761 S_modkids(pTHX_ OP *o, I32 type)
1763 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1766 op_lvalue(kid, type);
1772 =for apidoc finalize_optree
1774 This function finalizes the optree. Should be called directly after
1775 the complete optree is built. It does some additional
1776 checking which can't be done in the normal ck_xxx functions and makes
1777 the tree thread-safe.
1782 Perl_finalize_optree(pTHX_ OP* o)
1784 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1787 SAVEVPTR(PL_curcop);
1795 S_finalize_op(pTHX_ OP* o)
1797 PERL_ARGS_ASSERT_FINALIZE_OP;
1799 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1801 /* Make sure mad ops are also thread-safe */
1802 MADPROP *mp = o->op_madprop;
1804 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1805 OP *prop_op = (OP *) mp->mad_val;
1806 /* We only need "Relocate sv to the pad for thread safety.", but this
1807 easiest way to make sure it traverses everything */
1808 if (prop_op->op_type == OP_CONST)
1809 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1810 finalize_op(prop_op);
1817 switch (o->op_type) {
1820 PL_curcop = ((COP*)o); /* for warnings */
1824 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1825 && ckWARN(WARN_EXEC))
1827 if (o->op_sibling->op_sibling) {
1828 const OPCODE type = o->op_sibling->op_sibling->op_type;
1829 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1830 const line_t oldline = CopLINE(PL_curcop);
1831 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1832 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1833 "Statement unlikely to be reached");
1834 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1835 "\t(Maybe you meant system() when you said exec()?)\n");
1836 CopLINE_set(PL_curcop, oldline);
1843 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1844 GV * const gv = cGVOPo_gv;
1845 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1846 /* XXX could check prototype here instead of just carping */
1847 SV * const sv = sv_newmortal();
1848 gv_efullname3(sv, gv, NULL);
1849 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1850 "%"SVf"() called too early to check prototype",
1857 if (cSVOPo->op_private & OPpCONST_STRICT)
1858 no_bareword_allowed(o);
1862 case OP_METHOD_NAMED:
1863 /* Relocate sv to the pad for thread safety.
1864 * Despite being a "constant", the SV is written to,
1865 * for reference counts, sv_upgrade() etc. */
1866 if (cSVOPo->op_sv) {
1867 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1868 SvREFCNT_dec(PAD_SVl(ix));
1869 PAD_SETSV(ix, cSVOPo->op_sv);
1870 /* XXX I don't know how this isn't readonly already. */
1871 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1872 cSVOPo->op_sv = NULL;
1883 const char *key = NULL;
1886 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1889 /* Make the CONST have a shared SV */
1890 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1891 if ((!SvIsCOW_shared_hash(sv = *svp))
1892 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1893 key = SvPV_const(sv, keylen);
1894 lexname = newSVpvn_share(key,
1895 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1897 SvREFCNT_dec_NN(sv);
1901 if ((o->op_private & (OPpLVAL_INTRO)))
1904 rop = (UNOP*)((BINOP*)o)->op_first;
1905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1908 if (!SvPAD_TYPED(lexname))
1910 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1911 if (!fields || !GvHV(*fields))
1913 if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1914 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1915 "in variable %"SVf" of type %"HEKf,
1916 SVfARG(*svp), SVfARG(lexname),
1917 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1927 SVOP *first_key_op, *key_op;
1929 S_scalar_slice_warning(aTHX_ o);
1931 if ((o->op_private & (OPpLVAL_INTRO))
1932 /* I bet there's always a pushmark... */
1933 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1934 /* hmmm, no optimization if list contains only one key. */
1936 rop = (UNOP*)((LISTOP*)o)->op_last;
1937 if (rop->op_type != OP_RV2HV)
1939 if (rop->op_first->op_type == OP_PADSV)
1940 /* @$hash{qw(keys here)} */
1941 rop = (UNOP*)rop->op_first;
1943 /* @{$hash}{qw(keys here)} */
1944 if (rop->op_first->op_type == OP_SCOPE
1945 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1947 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1953 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1954 if (!SvPAD_TYPED(lexname))
1956 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1957 if (!fields || !GvHV(*fields))
1959 /* Again guessing that the pushmark can be jumped over.... */
1960 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1961 ->op_first->op_sibling;
1962 for (key_op = first_key_op; key_op;
1963 key_op = (SVOP*)key_op->op_sibling) {
1964 if (key_op->op_type != OP_CONST)
1966 svp = cSVOPx_svp(key_op);
1967 if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1968 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1969 "in variable %"SVf" of type %"HEKf,
1970 SVfARG(*svp), SVfARG(lexname),
1971 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1977 S_scalar_slice_warning(aTHX_ o);
1981 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1982 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1989 if (o->op_flags & OPf_KIDS) {
1991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1997 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1999 Propagate lvalue ("modifiable") context to an op and its children.
2000 I<type> represents the context type, roughly based on the type of op that
2001 would do the modifying, although C<local()> is represented by OP_NULL,
2002 because it has no op type of its own (it is signalled by a flag on
2005 This function detects things that can't be modified, such as C<$x+1>, and
2006 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2007 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2009 It also flags things that need to behave specially in an lvalue context,
2010 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2016 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2023 if (!o || (PL_parser && PL_parser->error_count))
2026 if ((o->op_private & OPpTARGET_MY)
2027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2032 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2034 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2036 switch (o->op_type) {
2041 if ((o->op_flags & OPf_PARENS) || PL_madskills)
2045 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2046 !(o->op_flags & OPf_STACKED)) {
2047 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2048 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2049 poses, so we need it clear. */
2050 o->op_private &= ~1;
2051 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2052 assert(cUNOPo->op_first->op_type == OP_NULL);
2053 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2056 else { /* lvalue subroutine call */
2057 o->op_private |= OPpLVAL_INTRO
2058 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2059 PL_modcount = RETURN_UNLIMITED_NUMBER;
2060 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2061 /* Potential lvalue context: */
2062 o->op_private |= OPpENTERSUB_INARGS;
2065 else { /* Compile-time error message: */
2066 OP *kid = cUNOPo->op_first;
2069 if (kid->op_type != OP_PUSHMARK) {
2070 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2072 "panic: unexpected lvalue entersub "
2073 "args: type/targ %ld:%"UVuf,
2074 (long)kid->op_type, (UV)kid->op_targ);
2075 kid = kLISTOP->op_first;
2077 while (kid->op_sibling)
2078 kid = kid->op_sibling;
2079 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2080 break; /* Postpone until runtime */
2083 kid = kUNOP->op_first;
2084 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2085 kid = kUNOP->op_first;
2086 if (kid->op_type == OP_NULL)
2088 "Unexpected constant lvalue entersub "
2089 "entry via type/targ %ld:%"UVuf,
2090 (long)kid->op_type, (UV)kid->op_targ);
2091 if (kid->op_type != OP_GV) {
2095 cv = GvCV(kGVOP_gv);
2105 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2106 /* grep, foreach, subcalls, refgen */
2107 if (type == OP_GREPSTART || type == OP_ENTERSUB
2108 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2110 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2111 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2113 : (o->op_type == OP_ENTERSUB
2114 ? "non-lvalue subroutine call"
2116 type ? PL_op_desc[type] : "local"));
2130 case OP_RIGHT_SHIFT:
2139 if (!(o->op_flags & OPf_STACKED))
2146 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2147 op_lvalue(kid, type);
2152 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2153 PL_modcount = RETURN_UNLIMITED_NUMBER;
2154 return o; /* Treat \(@foo) like ordinary list. */
2158 if (scalar_mod_type(o, type))
2160 ref(cUNOPo->op_first, o->op_type);
2167 if (type == OP_LEAVESUBLV)
2168 o->op_private |= OPpMAYBE_LVSUB;
2172 PL_modcount = RETURN_UNLIMITED_NUMBER;
2176 if (type == OP_LEAVESUBLV)
2177 o->op_private |= OPpMAYBE_LVSUB;
2180 PL_hints |= HINT_BLOCK_SCOPE;
2181 if (type == OP_LEAVESUBLV)
2182 o->op_private |= OPpMAYBE_LVSUB;
2186 ref(cUNOPo->op_first, o->op_type);
2190 PL_hints |= HINT_BLOCK_SCOPE;
2199 case OP_AELEMFAST_LEX:
2206 PL_modcount = RETURN_UNLIMITED_NUMBER;
2207 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2208 return o; /* Treat \(@foo) like ordinary list. */
2209 if (scalar_mod_type(o, type))
2211 if (type == OP_LEAVESUBLV)
2212 o->op_private |= OPpMAYBE_LVSUB;
2216 if (!type) /* local() */
2217 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2218 PAD_COMPNAME_SV(o->op_targ));
2227 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2231 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2237 if (type == OP_LEAVESUBLV)
2238 o->op_private |= OPpMAYBE_LVSUB;
2239 if (o->op_flags & OPf_KIDS)
2240 op_lvalue(cBINOPo->op_first->op_sibling, type);
2245 ref(cBINOPo->op_first, o->op_type);
2246 if (type == OP_ENTERSUB &&
2247 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2248 o->op_private |= OPpLVAL_DEFER;
2249 if (type == OP_LEAVESUBLV)
2250 o->op_private |= OPpMAYBE_LVSUB;
2260 if (o->op_flags & OPf_KIDS)
2261 op_lvalue(cLISTOPo->op_last, type);
2266 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2268 else if (!(o->op_flags & OPf_KIDS))
2270 if (o->op_targ != OP_LIST) {
2271 op_lvalue(cBINOPo->op_first, type);
2277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2278 /* elements might be in void context because the list is
2279 in scalar context or because they are attribute sub calls */
2280 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2281 op_lvalue(kid, type);
2285 if (type != OP_LEAVESUBLV)
2287 break; /* op_lvalue()ing was handled by ck_return() */
2293 /* [20011101.069] File test operators interpret OPf_REF to mean that
2294 their argument is a filehandle; thus \stat(".") should not set
2296 if (type == OP_REFGEN &&
2297 PL_check[o->op_type] == Perl_ck_ftst)
2300 if (type != OP_LEAVESUBLV)
2301 o->op_flags |= OPf_MOD;
2303 if (type == OP_AASSIGN || type == OP_SASSIGN)
2304 o->op_flags |= OPf_SPECIAL|OPf_REF;
2305 else if (!type) { /* local() */
2308 o->op_private |= OPpLVAL_INTRO;
2309 o->op_flags &= ~OPf_SPECIAL;
2310 PL_hints |= HINT_BLOCK_SCOPE;
2315 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2316 "Useless localization of %s", OP_DESC(o));
2319 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2320 && type != OP_LEAVESUBLV)
2321 o->op_flags |= OPf_REF;
2326 S_scalar_mod_type(const OP *o, I32 type)
2331 if (o && o->op_type == OP_RV2GV)
2355 case OP_RIGHT_SHIFT:
2376 S_is_handle_constructor(const OP *o, I32 numargs)
2378 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2380 switch (o->op_type) {
2388 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2401 S_refkids(pTHX_ OP *o, I32 type)
2403 if (o && o->op_flags & OPf_KIDS) {
2405 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2412 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2417 PERL_ARGS_ASSERT_DOREF;
2419 if (!o || (PL_parser && PL_parser->error_count))
2422 switch (o->op_type) {
2424 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2425 !(o->op_flags & OPf_STACKED)) {
2426 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2427 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2428 assert(cUNOPo->op_first->op_type == OP_NULL);
2429 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2430 o->op_flags |= OPf_SPECIAL;
2431 o->op_private &= ~1;
2433 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2434 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2435 : type == OP_RV2HV ? OPpDEREF_HV
2437 o->op_flags |= OPf_MOD;
2443 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2444 doref(kid, type, set_op_ref);
2447 if (type == OP_DEFINED)
2448 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2449 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2452 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2453 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2454 : type == OP_RV2HV ? OPpDEREF_HV
2456 o->op_flags |= OPf_MOD;
2463 o->op_flags |= OPf_REF;
2466 if (type == OP_DEFINED)
2467 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2468 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2474 o->op_flags |= OPf_REF;
2479 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2481 doref(cBINOPo->op_first, type, set_op_ref);
2485 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2486 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2487 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2488 : type == OP_RV2HV ? OPpDEREF_HV
2490 o->op_flags |= OPf_MOD;
2500 if (!(o->op_flags & OPf_KIDS))
2502 doref(cLISTOPo->op_last, type, set_op_ref);
2512 S_dup_attrlist(pTHX_ OP *o)
2517 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2519 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2520 * where the first kid is OP_PUSHMARK and the remaining ones
2521 * are OP_CONST. We need to push the OP_CONST values.
2523 if (o->op_type == OP_CONST)
2524 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2526 else if (o->op_type == OP_NULL)
2530 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2532 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2533 if (o->op_type == OP_CONST)
2534 rop = op_append_elem(OP_LIST, rop,
2535 newSVOP(OP_CONST, o->op_flags,
2536 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2543 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2546 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2548 PERL_ARGS_ASSERT_APPLY_ATTRS;
2550 /* fake up C<use attributes $pkg,$rv,@attrs> */
2551 ENTER; /* need to protect against side-effects of 'use' */
2553 #define ATTRSMODULE "attributes"
2554 #define ATTRSMODULE_PM "attributes.pm"
2556 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2557 newSVpvs(ATTRSMODULE),
2559 op_prepend_elem(OP_LIST,
2560 newSVOP(OP_CONST, 0, stashsv),
2561 op_prepend_elem(OP_LIST,
2562 newSVOP(OP_CONST, 0,
2564 dup_attrlist(attrs))));
2569 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2572 OP *pack, *imop, *arg;
2573 SV *meth, *stashsv, **svp;
2575 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2580 assert(target->op_type == OP_PADSV ||
2581 target->op_type == OP_PADHV ||
2582 target->op_type == OP_PADAV);
2584 /* Ensure that attributes.pm is loaded. */
2585 ENTER; /* need to protect against side-effects of 'use' */
2586 /* Don't force the C<use> if we don't need it. */
2587 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2588 if (svp && *svp != &PL_sv_undef)
2589 NOOP; /* already in %INC */
2591 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2592 newSVpvs(ATTRSMODULE), NULL);
2595 /* Need package name for method call. */
2596 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2598 /* Build up the real arg-list. */
2599 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2601 arg = newOP(OP_PADSV, 0);
2602 arg->op_targ = target->op_targ;
2603 arg = op_prepend_elem(OP_LIST,
2604 newSVOP(OP_CONST, 0, stashsv),
2605 op_prepend_elem(OP_LIST,
2606 newUNOP(OP_REFGEN, 0,
2607 op_lvalue(arg, OP_REFGEN)),
2608 dup_attrlist(attrs)));
2610 /* Fake up a method call to import */
2611 meth = newSVpvs_share("import");
2612 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2613 op_append_elem(OP_LIST,
2614 op_prepend_elem(OP_LIST, pack, list(arg)),
2615 newSVOP(OP_METHOD_NAMED, 0, meth)));
2617 /* Combine the ops. */
2618 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2622 =notfor apidoc apply_attrs_string
2624 Attempts to apply a list of attributes specified by the C<attrstr> and
2625 C<len> arguments to the subroutine identified by the C<cv> argument which
2626 is expected to be associated with the package identified by the C<stashpv>
2627 argument (see L<attributes>). It gets this wrong, though, in that it
2628 does not correctly identify the boundaries of the individual attribute
2629 specifications within C<attrstr>. This is not really intended for the
2630 public API, but has to be listed here for systems such as AIX which
2631 need an explicit export list for symbols. (It's called from XS code
2632 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2633 to respect attribute syntax properly would be welcome.
2639 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2640 const char *attrstr, STRLEN len)
2644 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2647 len = strlen(attrstr);
2651 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2653 const char * const sstr = attrstr;
2654 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2655 attrs = op_append_elem(OP_LIST, attrs,
2656 newSVOP(OP_CONST, 0,
2657 newSVpvn(sstr, attrstr-sstr)));
2661 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2662 newSVpvs(ATTRSMODULE),
2663 NULL, op_prepend_elem(OP_LIST,
2664 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2665 op_prepend_elem(OP_LIST,
2666 newSVOP(OP_CONST, 0,
2667 newRV(MUTABLE_SV(cv))),
2672 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2676 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2678 PERL_ARGS_ASSERT_MY_KID;
2680 if (!o || (PL_parser && PL_parser->error_count))
2684 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2685 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2689 if (type == OP_LIST) {
2691 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2692 my_kid(kid, attrs, imopsp);
2694 } else if (type == OP_UNDEF || type == OP_STUB) {
2696 } else if (type == OP_RV2SV || /* "our" declaration */
2698 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2699 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2700 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2702 PL_parser->in_my == KEY_our
2704 : PL_parser->in_my == KEY_state ? "state" : "my"));
2706 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2707 PL_parser->in_my = FALSE;
2708 PL_parser->in_my_stash = NULL;
2709 apply_attrs(GvSTASH(gv),
2710 (type == OP_RV2SV ? GvSV(gv) :
2711 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2712 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2715 o->op_private |= OPpOUR_INTRO;
2718 else if (type != OP_PADSV &&
2721 type != OP_PUSHMARK)
2723 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2725 PL_parser->in_my == KEY_our
2727 : PL_parser->in_my == KEY_state ? "state" : "my"));
2730 else if (attrs && type != OP_PUSHMARK) {
2733 PL_parser->in_my = FALSE;
2734 PL_parser->in_my_stash = NULL;
2736 /* check for C<my Dog $spot> when deciding package */
2737 stash = PAD_COMPNAME_TYPE(o->op_targ);
2739 stash = PL_curstash;
2740 apply_attrs_my(stash, o, attrs, imopsp);
2742 o->op_flags |= OPf_MOD;
2743 o->op_private |= OPpLVAL_INTRO;
2745 o->op_private |= OPpPAD_STATE;
2750 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2754 int maybe_scalar = 0;
2756 PERL_ARGS_ASSERT_MY_ATTRS;
2758 /* [perl #17376]: this appears to be premature, and results in code such as
2759 C< our(%x); > executing in list mode rather than void mode */
2761 if (o->op_flags & OPf_PARENS)
2771 o = my_kid(o, attrs, &rops);
2773 if (maybe_scalar && o->op_type == OP_PADSV) {
2774 o = scalar(op_append_list(OP_LIST, rops, o));
2775 o->op_private |= OPpLVAL_INTRO;
2778 /* The listop in rops might have a pushmark at the beginning,
2779 which will mess up list assignment. */
2780 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2781 if (rops->op_type == OP_LIST &&
2782 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2784 OP * const pushmark = lrops->op_first;
2785 lrops->op_first = pushmark->op_sibling;
2788 o = op_append_list(OP_LIST, o, rops);
2791 PL_parser->in_my = FALSE;
2792 PL_parser->in_my_stash = NULL;
2797 Perl_sawparens(pTHX_ OP *o)
2799 PERL_UNUSED_CONTEXT;
2801 o->op_flags |= OPf_PARENS;
2806 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2810 const OPCODE ltype = left->op_type;
2811 const OPCODE rtype = right->op_type;
2813 PERL_ARGS_ASSERT_BIND_MATCH;
2815 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2816 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2818 const char * const desc
2820 rtype == OP_SUBST || rtype == OP_TRANS
2821 || rtype == OP_TRANSR
2823 ? (int)rtype : OP_MATCH];
2824 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2826 S_op_varname(aTHX_ left);
2828 Perl_warner(aTHX_ packWARN(WARN_MISC),
2829 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2832 const char * const sample = (isary
2833 ? "@array" : "%hash");
2834 Perl_warner(aTHX_ packWARN(WARN_MISC),
2835 "Applying %s to %s will act on scalar(%s)",
2836 desc, sample, sample);
2840 if (rtype == OP_CONST &&
2841 cSVOPx(right)->op_private & OPpCONST_BARE &&
2842 cSVOPx(right)->op_private & OPpCONST_STRICT)
2844 no_bareword_allowed(right);
2847 /* !~ doesn't make sense with /r, so error on it for now */
2848 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2850 yyerror("Using !~ with s///r doesn't make sense");
2851 if (rtype == OP_TRANSR && type == OP_NOT)
2852 yyerror("Using !~ with tr///r doesn't make sense");
2854 ismatchop = (rtype == OP_MATCH ||
2855 rtype == OP_SUBST ||
2856 rtype == OP_TRANS || rtype == OP_TRANSR)
2857 && !(right->op_flags & OPf_SPECIAL);
2858 if (ismatchop && right->op_private & OPpTARGET_MY) {
2860 right->op_private &= ~OPpTARGET_MY;
2862 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2865 right->op_flags |= OPf_STACKED;
2866 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2867 ! (rtype == OP_TRANS &&
2868 right->op_private & OPpTRANS_IDENTICAL) &&
2869 ! (rtype == OP_SUBST &&
2870 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2871 newleft = op_lvalue(left, rtype);
2874 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2875 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2877 o = op_prepend_elem(rtype, scalar(newleft), right);
2879 return newUNOP(OP_NOT, 0, scalar(o));
2883 return bind_match(type, left,
2884 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2888 Perl_invert(pTHX_ OP *o)
2892 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2896 =for apidoc Amx|OP *|op_scope|OP *o
2898 Wraps up an op tree with some additional ops so that at runtime a dynamic
2899 scope will be created. The original ops run in the new dynamic scope,
2900 and then, provided that they exit normally, the scope will be unwound.
2901 The additional ops used to create and unwind the dynamic scope will
2902 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2903 instead if the ops are simple enough to not need the full dynamic scope
2910 Perl_op_scope(pTHX_ OP *o)
2914 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2915 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2916 o->op_type = OP_LEAVE;
2917 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2919 else if (o->op_type == OP_LINESEQ) {
2921 o->op_type = OP_SCOPE;
2922 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2923 kid = ((LISTOP*)o)->op_first;
2924 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2927 /* The following deals with things like 'do {1 for 1}' */
2928 kid = kid->op_sibling;
2930 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2935 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2941 Perl_op_unscope(pTHX_ OP *o)
2943 if (o && o->op_type == OP_LINESEQ) {
2944 OP *kid = cLISTOPo->op_first;
2945 for(; kid; kid = kid->op_sibling)
2946 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2953 Perl_block_start(pTHX_ int full)
2956 const int retval = PL_savestack_ix;
2958 pad_block_start(full);
2960 PL_hints &= ~HINT_BLOCK_SCOPE;
2961 SAVECOMPILEWARNINGS();
2962 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2964 CALL_BLOCK_HOOKS(bhk_start, full);
2970 Perl_block_end(pTHX_ I32 floor, OP *seq)
2973 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2974 OP* retval = scalarseq(seq);
2977 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2981 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2985 /* pad_leavemy has created a sequence of introcv ops for all my
2986 subs declared in the block. We have to replicate that list with
2987 clonecv ops, to deal with this situation:
2992 sub s1 { state sub foo { \&s2 } }
2995 Originally, I was going to have introcv clone the CV and turn
2996 off the stale flag. Since &s1 is declared before &s2, the
2997 introcv op for &s1 is executed (on sub entry) before the one for
2998 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2999 cloned, since it is a state sub) closes over &s2 and expects
3000 to see it in its outer CV’s pad. If the introcv op clones &s1,
3001 then &s2 is still marked stale. Since &s1 is not active, and
3002 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3003 ble will not stay shared’ warning. Because it is the same stub
3004 that will be used when the introcv op for &s2 is executed, clos-
3005 ing over it is safe. Hence, we have to turn off the stale flag
3006 on all lexical subs in the block before we clone any of them.
3007 Hence, having introcv clone the sub cannot work. So we create a
3008 list of ops like this:
3032 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3033 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3034 for (;; kid = kid->op_sibling) {
3035 OP *newkid = newOP(OP_CLONECV, 0);
3036 newkid->op_targ = kid->op_targ;
3037 o = op_append_elem(OP_LINESEQ, o, newkid);
3038 if (kid == last) break;
3040 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3043 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3049 =head1 Compile-time scope hooks
3051 =for apidoc Aox||blockhook_register
3053 Register a set of hooks to be called when the Perl lexical scope changes
3054 at compile time. See L<perlguts/"Compile-time scope hooks">.
3060 Perl_blockhook_register(pTHX_ BHK *hk)
3062 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3064 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3071 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3072 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3073 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3076 OP * const o = newOP(OP_PADSV, 0);
3077 o->op_targ = offset;
3083 Perl_newPROG(pTHX_ OP *o)
3087 PERL_ARGS_ASSERT_NEWPROG;
3094 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3095 ((PL_in_eval & EVAL_KEEPERR)
3096 ? OPf_SPECIAL : 0), o);
3098 cx = &cxstack[cxstack_ix];
3099 assert(CxTYPE(cx) == CXt_EVAL);
3101 if ((cx->blk_gimme & G_WANT) == G_VOID)
3102 scalarvoid(PL_eval_root);
3103 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3106 scalar(PL_eval_root);
3108 PL_eval_start = op_linklist(PL_eval_root);
3109 PL_eval_root->op_private |= OPpREFCOUNTED;
3110 OpREFCNT_set(PL_eval_root, 1);
3111 PL_eval_root->op_next = 0;
3112 i = PL_savestack_ix;
3115 CALL_PEEP(PL_eval_start);
3116 finalize_optree(PL_eval_root);
3118 PL_savestack_ix = i;
3121 if (o->op_type == OP_STUB) {
3122 /* This block is entered if nothing is compiled for the main
3123 program. This will be the case for an genuinely empty main
3124 program, or one which only has BEGIN blocks etc, so already
3127 Historically (5.000) the guard above was !o. However, commit
3128 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3129 c71fccf11fde0068, changed perly.y so that newPROG() is now
3130 called with the output of block_end(), which returns a new
3131 OP_STUB for the case of an empty optree. ByteLoader (and
3132 maybe other things) also take this path, because they set up
3133 PL_main_start and PL_main_root directly, without generating an
3136 If the parsing the main program aborts (due to parse errors,
3137 or due to BEGIN or similar calling exit), then newPROG()
3138 isn't even called, and hence this code path and its cleanups
3139 are skipped. This shouldn't make a make a difference:
3140 * a non-zero return from perl_parse is a failure, and
3141 perl_destruct() should be called immediately.
3142 * however, if exit(0) is called during the parse, then
3143 perl_parse() returns 0, and perl_run() is called. As
3144 PL_main_start will be NULL, perl_run() will return
3145 promptly, and the exit code will remain 0.
3148 PL_comppad_name = 0;
3150 S_op_destroy(aTHX_ o);
3153 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3154 PL_curcop = &PL_compiling;
3155 PL_main_start = LINKLIST(PL_main_root);
3156 PL_main_root->op_private |= OPpREFCOUNTED;
3157 OpREFCNT_set(PL_main_root, 1);
3158 PL_main_root->op_next = 0;
3159 CALL_PEEP(PL_main_start);
3160 finalize_optree(PL_main_root);
3161 cv_forget_slab(PL_compcv);
3164 /* Register with debugger */
3166 CV * const cv = get_cvs("DB::postponed", 0);
3170 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3172 call_sv(MUTABLE_SV(cv), G_DISCARD);
3179 Perl_localize(pTHX_ OP *o, I32 lex)
3183 PERL_ARGS_ASSERT_LOCALIZE;
3185 if (o->op_flags & OPf_PARENS)
3186 /* [perl #17376]: this appears to be premature, and results in code such as
3187 C< our(%x); > executing in list mode rather than void mode */
3194 if ( PL_parser->bufptr > PL_parser->oldbufptr
3195 && PL_parser->bufptr[-1] == ','
3196 && ckWARN(WARN_PARENTHESIS))
3198 char *s = PL_parser->bufptr;
3201 /* some heuristics to detect a potential error */
3202 while (*s && (strchr(", \t\n", *s)))
3206 if (*s && strchr("@$%*", *s) && *++s
3207 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3210 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3212 while (*s && (strchr(", \t\n", *s)))
3218 if (sigil && (*s == ';' || *s == '=')) {
3219 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3220 "Parentheses missing around \"%s\" list",
3222 ? (PL_parser->in_my == KEY_our
3224 : PL_parser->in_my == KEY_state
3234 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3235 PL_parser->in_my = FALSE;
3236 PL_parser->in_my_stash = NULL;
3241 Perl_jmaybe(pTHX_ OP *o)
3243 PERL_ARGS_ASSERT_JMAYBE;
3245 if (o->op_type == OP_LIST) {
3247 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3248 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3253 PERL_STATIC_INLINE OP *
3254 S_op_std_init(pTHX_ OP *o)
3256 I32 type = o->op_type;
3258 PERL_ARGS_ASSERT_OP_STD_INIT;
3260 if (PL_opargs[type] & OA_RETSCALAR)
3262 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3263 o->op_targ = pad_alloc(type, SVs_PADTMP);
3268 PERL_STATIC_INLINE OP *
3269 S_op_integerize(pTHX_ OP *o)
3271 I32 type = o->op_type;
3273 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3275 /* integerize op. */
3276 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3279 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3282 if (type == OP_NEGATE)
3283 /* XXX might want a ck_negate() for this */
3284 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3290 S_fold_constants(pTHX_ OP *o)
3295 VOL I32 type = o->op_type;
3300 SV * const oldwarnhook = PL_warnhook;
3301 SV * const olddiehook = PL_diehook;
3305 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3307 if (!(PL_opargs[type] & OA_FOLDCONST))
3322 /* XXX what about the numeric ops? */
3323 if (IN_LOCALE_COMPILETIME)
3327 if (!cLISTOPo->op_first->op_sibling
3328 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3331 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3332 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3334 const char *s = SvPVX_const(sv);
3335 while (s < SvEND(sv)) {
3336 if (*s == 'p' || *s == 'P') goto nope;
3343 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3346 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3347 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3351 if (PL_parser && PL_parser->error_count)
3352 goto nope; /* Don't try to run w/ errors */
3354 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3355 const OPCODE type = curop->op_type;
3356 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3358 type != OP_SCALAR &&
3360 type != OP_PUSHMARK)
3366 curop = LINKLIST(o);
3367 old_next = o->op_next;
3371 oldscope = PL_scopestack_ix;
3372 create_eval_scope(G_FAKINGEVAL);
3374 /* Verify that we don't need to save it: */
3375 assert(PL_curcop == &PL_compiling);
3376 StructCopy(&PL_compiling, ¬_compiling, COP);
3377 PL_curcop = ¬_compiling;
3378 /* The above ensures that we run with all the correct hints of the
3379 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3380 assert(IN_PERL_RUNTIME);
3381 PL_warnhook = PERL_WARNHOOK_FATAL;
3388 sv = *(PL_stack_sp--);
3389 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3391 /* Can't simply swipe the SV from the pad, because that relies on
3392 the op being freed "real soon now". Under MAD, this doesn't
3393 happen (see the #ifdef below). */
3396 pad_swipe(o->op_targ, FALSE);
3399 else if (SvTEMP(sv)) { /* grab mortal temp? */
3400 SvREFCNT_inc_simple_void(sv);
3403 else { assert(SvIMMORTAL(sv)); }
3406 /* Something tried to die. Abandon constant folding. */
3407 /* Pretend the error never happened. */
3409 o->op_next = old_next;
3413 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3414 PL_warnhook = oldwarnhook;
3415 PL_diehook = olddiehook;
3416 /* XXX note that this croak may fail as we've already blown away
3417 * the stack - eg any nested evals */
3418 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3421 PL_warnhook = oldwarnhook;
3422 PL_diehook = olddiehook;
3423 PL_curcop = &PL_compiling;
3425 if (PL_scopestack_ix > oldscope)
3426 delete_eval_scope();
3435 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3436 else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
3437 if (type == OP_RV2GV)
3438 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3441 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3442 if (type != OP_STRINGIFY) newop->op_folded = 1;
3444 op_getmad(o,newop,'f');
3452 S_gen_constant_list(pTHX_ OP *o)
3456 const SSize_t oldtmps_floor = PL_tmps_floor;
3461 if (PL_parser && PL_parser->error_count)
3462 return o; /* Don't attempt to run with errors */
3464 PL_op = curop = LINKLIST(o);
3467 Perl_pp_pushmark(aTHX);
3470 assert (!(curop->op_flags & OPf_SPECIAL));
3471 assert(curop->op_type == OP_RANGE);
3472 Perl_pp_anonlist(aTHX);
3473 PL_tmps_floor = oldtmps_floor;
3475 o->op_type = OP_RV2AV;
3476 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3477 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3478 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3479 o->op_opt = 0; /* needs to be revisited in rpeep() */
3480 curop = ((UNOP*)o)->op_first;
3481 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3482 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3483 if (AvFILLp(av) != -1)
3484 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3487 op_getmad(curop,o,'O');
3496 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3499 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3500 if (!o || o->op_type != OP_LIST)
3501 o = newLISTOP(OP_LIST, 0, o, NULL);
3503 o->op_flags &= ~OPf_WANT;
3505 if (!(PL_opargs[type] & OA_MARK))
3506 op_null(cLISTOPo->op_first);
3508 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3509 if (kid2 && kid2->op_type == OP_COREARGS) {
3510 op_null(cLISTOPo->op_first);
3511 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3515 o->op_type = (OPCODE)type;
3516 o->op_ppaddr = PL_ppaddr[type];
3517 o->op_flags |= flags;
3519 o = CHECKOP(type, o);
3520 if (o->op_type != (unsigned)type)
3523 return fold_constants(op_integerize(op_std_init(o)));
3527 =head1 Optree Manipulation Functions
3530 /* List constructors */
3533 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3535 Append an item to the list of ops contained directly within a list-type
3536 op, returning the lengthened list. I<first> is the list-type op,
3537 and I<last> is the op to append to the list. I<optype> specifies the
3538 intended opcode for the list. If I<first> is not already a list of the
3539 right type, it will be upgraded into one. If either I<first> or I<last>
3540 is null, the other is returned unchanged.
3546 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3554 if (first->op_type != (unsigned)type
3555 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3557 return newLISTOP(type, 0, first, last);
3560 if (first->op_flags & OPf_KIDS)
3561 ((LISTOP*)first)->op_last->op_sibling = last;
3563 first->op_flags |= OPf_KIDS;
3564 ((LISTOP*)first)->op_first = last;
3566 ((LISTOP*)first)->op_last = last;
3571 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3573 Concatenate the lists of ops contained directly within two list-type ops,
3574 returning the combined list. I<first> and I<last> are the list-type ops
3575 to concatenate. I<optype> specifies the intended opcode for the list.
3576 If either I<first> or I<last> is not already a list of the right type,
3577 it will be upgraded into one. If either I<first> or I<last> is null,
3578 the other is returned unchanged.
3584 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3592 if (first->op_type != (unsigned)type)
3593 return op_prepend_elem(type, first, last);
3595 if (last->op_type != (unsigned)type)
3596 return op_append_elem(type, first, last);
3598 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3599 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3600 first->op_flags |= (last->op_flags & OPf_KIDS);
3603 if (((LISTOP*)last)->op_first && first->op_madprop) {
3604 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3606 while (mp->mad_next)
3608 mp->mad_next = first->op_madprop;
3611 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3614 first->op_madprop = last->op_madprop;
3615 last->op_madprop = 0;
3618 S_op_destroy(aTHX_ last);
3624 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3626 Prepend an item to the list of ops contained directly within a list-type
3627 op, returning the lengthened list. I<first> is the op to prepend to the
3628 list, and I<last> is the list-type op. I<optype> specifies the intended
3629 opcode for the list. If I<last> is not already a list of the right type,
3630 it will be upgraded into one. If either I<first> or I<last> is null,
3631 the other is returned unchanged.
3637 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3645 if (last->op_type == (unsigned)type) {
3646 if (type == OP_LIST) { /* already a PUSHMARK there */
3647 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3648 ((LISTOP*)last)->op_first->op_sibling = first;
3649 if (!(first->op_flags & OPf_PARENS))
3650 last->op_flags &= ~OPf_PARENS;
3653 if (!(last->op_flags & OPf_KIDS)) {
3654 ((LISTOP*)last)->op_last = first;
3655 last->op_flags |= OPf_KIDS;
3657 first->op_sibling = ((LISTOP*)last)->op_first;
3658 ((LISTOP*)last)->op_first = first;
3660 last->op_flags |= OPf_KIDS;
3664 return newLISTOP(type, 0, first, last);
3672 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3675 Newxz(tk, 1, TOKEN);
3676 tk->tk_type = (OPCODE)optype;
3677 tk->tk_type = 12345;
3679 tk->tk_mad = madprop;
3684 Perl_token_free(pTHX_ TOKEN* tk)
3686 PERL_ARGS_ASSERT_TOKEN_FREE;
3688 if (tk->tk_type != 12345)
3690 mad_free(tk->tk_mad);
3695 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3700 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3702 if (tk->tk_type != 12345) {
3703 Perl_warner(aTHX_ packWARN(WARN_MISC),
3704 "Invalid TOKEN object ignored");
3711 /* faked up qw list? */
3713 tm->mad_type == MAD_SV &&
3714 SvPVX((SV *)tm->mad_val)[0] == 'q')
3721 /* pretend constant fold didn't happen? */
3722 if (mp->mad_key == 'f' &&
3723 (o->op_type == OP_CONST ||
3724 o->op_type == OP_GV) )
3726 token_getmad(tk,(OP*)mp->mad_val,slot);
3740 if (mp->mad_key == 'X')
3741 mp->mad_key = slot; /* just change the first one */
3751 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3760 /* pretend constant fold didn't happen? */
3761 if (mp->mad_key == 'f' &&
3762 (o->op_type == OP_CONST ||
3763 o->op_type == OP_GV) )
3765 op_getmad(from,(OP*)mp->mad_val,slot);
3772 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3775 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3781 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3790 /* pretend constant fold didn't happen? */
3791 if (mp->mad_key == 'f' &&
3792 (o->op_type == OP_CONST ||
3793 o->op_type == OP_GV) )
3795 op_getmad(from,(OP*)mp->mad_val,slot);
3802 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3805 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3809 PerlIO_printf(PerlIO_stderr(),
3810 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3816 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3834 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3838 addmad(tm, &(o->op_madprop), slot);
3842 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3863 Perl_newMADsv(pTHX_ char key, SV* sv)
3865 PERL_ARGS_ASSERT_NEWMADSV;
3867 return newMADPROP(key, MAD_SV, sv, 0);
3871 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3873 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3876 mp->mad_vlen = vlen;
3877 mp->mad_type = type;
3879 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3884 Perl_mad_free(pTHX_ MADPROP* mp)
3886 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3890 mad_free(mp->mad_next);
3891 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3892 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3893 switch (mp->mad_type) {
3897 Safefree(mp->mad_val);
3900 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3901 op_free((OP*)mp->mad_val);
3904 sv_free(MUTABLE_SV(mp->mad_val));
3907 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3910 PerlMemShared_free(mp);
3916 =head1 Optree construction
3918 =for apidoc Am|OP *|newNULLLIST
3920 Constructs, checks, and returns a new C<stub> op, which represents an
3921 empty list expression.
3927 Perl_newNULLLIST(pTHX)
3929 return newOP(OP_STUB, 0);
3933 S_force_list(pTHX_ OP *o)
3935 if (!o || o->op_type != OP_LIST)
3936 o = newLISTOP(OP_LIST, 0, o, NULL);
3942 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3944 Constructs, checks, and returns an op of any list type. I<type> is
3945 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3946 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3947 supply up to two ops to be direct children of the list op; they are
3948 consumed by this function and become part of the constructed op tree.
3954 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3959 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3961 NewOp(1101, listop, 1, LISTOP);
3963 listop->op_type = (OPCODE)type;
3964 listop->op_ppaddr = PL_ppaddr[type];
3967 listop->op_flags = (U8)flags;
3971 else if (!first && last)
3974 first->op_sibling = last;
3975 listop->op_first = first;
3976 listop->op_last = last;
3977 if (type == OP_LIST) {
3978 OP* const pushop = newOP(OP_PUSHMARK, 0);
3979 pushop->op_sibling = first;
3980 listop->op_first = pushop;
3981 listop->op_flags |= OPf_KIDS;
3983 listop->op_last = pushop;
3986 return CHECKOP(type, listop);
3990 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3992 Constructs, checks, and returns an op of any base type (any type that
3993 has no extra fields). I<type> is the opcode. I<flags> gives the
3994 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4001 Perl_newOP(pTHX_ I32 type, I32 flags)
4006 if (type == -OP_ENTEREVAL) {
4007 type = OP_ENTEREVAL;
4008 flags |= OPpEVAL_BYTES<<8;
4011 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4012 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4013 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4014 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4016 NewOp(1101, o, 1, OP);
4017 o->op_type = (OPCODE)type;
4018 o->op_ppaddr = PL_ppaddr[type];
4019 o->op_flags = (U8)flags;
4022 o->op_private = (U8)(0 | (flags >> 8));
4023 if (PL_opargs[type] & OA_RETSCALAR)
4025 if (PL_opargs[type] & OA_TARGET)
4026 o->op_targ = pad_alloc(type, SVs_PADTMP);
4027 return CHECKOP(type, o);
4031 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4033 Constructs, checks, and returns an op of any unary type. I<type> is
4034 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4035 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4036 bits, the eight bits of C<op_private>, except that the bit with value 1
4037 is automatically set. I<first> supplies an optional op to be the direct
4038 child of the unary op; it is consumed by this function and become part
4039 of the constructed op tree.
4045 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4050 if (type == -OP_ENTEREVAL) {
4051 type = OP_ENTEREVAL;
4052 flags |= OPpEVAL_BYTES<<8;
4055 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4056 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4057 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4058 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4059 || type == OP_SASSIGN
4060 || type == OP_ENTERTRY
4061 || type == OP_NULL );
4064 first = newOP(OP_STUB, 0);
4065 if (PL_opargs[type] & OA_MARK)
4066 first = force_list(first);
4068 NewOp(1101, unop, 1, UNOP);
4069 unop->op_type = (OPCODE)type;
4070 unop->op_ppaddr = PL_ppaddr[type];
4071 unop->op_first = first;
4072 unop->op_flags = (U8)(flags | OPf_KIDS);
4073 unop->op_private = (U8)(1 | (flags >> 8));
4074 unop = (UNOP*) CHECKOP(type, unop);
4078 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4082 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4084 Constructs, checks, and returns an op of any binary type. I<type>
4085 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4086 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4087 the eight bits of C<op_private>, except that the bit with value 1 or
4088 2 is automatically set as required. I<first> and I<last> supply up to
4089 two ops to be the direct children of the binary op; they are consumed
4090 by this function and become part of the constructed op tree.
4096 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4101 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4102 || type == OP_SASSIGN || type == OP_NULL );
4104 NewOp(1101, binop, 1, BINOP);
4107 first = newOP(OP_NULL, 0);
4109 binop->op_type = (OPCODE)type;
4110 binop->op_ppaddr = PL_ppaddr[type];
4111 binop->op_first = first;
4112 binop->op_flags = (U8)(flags | OPf_KIDS);
4115 binop->op_private = (U8)(1 | (flags >> 8));
4118 binop->op_private = (U8)(2 | (flags >> 8));
4119 first->op_sibling = last;
4122 binop = (BINOP*)CHECKOP(type, binop);
4123 if (binop->op_next || binop->op_type != (OPCODE)type)
4126 binop->op_last = binop->op_first->op_sibling;
4128 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4131 static int uvcompare(const void *a, const void *b)
4132 __attribute__nonnull__(1)
4133 __attribute__nonnull__(2)
4134 __attribute__pure__;
4135 static int uvcompare(const void *a, const void *b)
4137 if (*((const UV *)a) < (*(const UV *)b))
4139 if (*((const UV *)a) > (*(const UV *)b))
4141 if (*((const UV *)a+1) < (*(const UV *)b+1))
4143 if (*((const UV *)a+1) > (*(const UV *)b+1))
4149 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4152 SV * const tstr = ((SVOP*)expr)->op_sv;
4155 (repl->op_type == OP_NULL)
4156 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4158 ((SVOP*)repl)->op_sv;
4161 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4162 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4168 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4169 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4170 I32 del = o->op_private & OPpTRANS_DELETE;
4173 PERL_ARGS_ASSERT_PMTRANS;
4175 PL_hints |= HINT_BLOCK_SCOPE;
4178 o->op_private |= OPpTRANS_FROM_UTF;
4181 o->op_private |= OPpTRANS_TO_UTF;
4183 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4184 SV* const listsv = newSVpvs("# comment\n");
4186 const U8* tend = t + tlen;
4187 const U8* rend = r + rlen;
4201 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4202 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4205 const U32 flags = UTF8_ALLOW_DEFAULT;
4209 t = tsave = bytes_to_utf8(t, &len);
4212 if (!to_utf && rlen) {
4214 r = rsave = bytes_to_utf8(r, &len);
4218 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4219 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4223 U8 tmpbuf[UTF8_MAXBYTES+1];
4226 Newx(cp, 2*tlen, UV);
4228 transv = newSVpvs("");
4230 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4232 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4234 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4238 cp[2*i+1] = cp[2*i];
4242 qsort(cp, i, 2*sizeof(UV), uvcompare);
4243 for (j = 0; j < i; j++) {
4245 diff = val - nextmin;
4247 t = uvchr_to_utf8(tmpbuf,nextmin);
4248 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4250 U8 range_mark = ILLEGAL_UTF8_BYTE;
4251 t = uvchr_to_utf8(tmpbuf, val - 1);
4252 sv_catpvn(transv, (char *)&range_mark, 1);
4253 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4260 t = uvchr_to_utf8(tmpbuf,nextmin);
4261 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4263 U8 range_mark = ILLEGAL_UTF8_BYTE;
4264 sv_catpvn(transv, (char *)&range_mark, 1);
4266 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4267 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4268 t = (const U8*)SvPVX_const(transv);
4269 tlen = SvCUR(transv);
4273 else if (!rlen && !del) {
4274 r = t; rlen = tlen; rend = tend;
4277 if ((!rlen && !del) || t == r ||
4278 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4280 o->op_private |= OPpTRANS_IDENTICAL;
4284 while (t < tend || tfirst <= tlast) {
4285 /* see if we need more "t" chars */
4286 if (tfirst > tlast) {
4287 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4289 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4291 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4298 /* now see if we need more "r" chars */
4299 if (rfirst > rlast) {
4301 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4303 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4305 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4314 rfirst = rlast = 0xffffffff;
4318 /* now see which range will peter our first, if either. */
4319 tdiff = tlast - tfirst;
4320 rdiff = rlast - rfirst;
4327 if (rfirst == 0xffffffff) {
4328 diff = tdiff; /* oops, pretend rdiff is infinite */
4330 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4331 (long)tfirst, (long)tlast);
4333 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4337 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4338 (long)tfirst, (long)(tfirst + diff),
4341 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4342 (long)tfirst, (long)rfirst);
4344 if (rfirst + diff > max)
4345 max = rfirst + diff;
4347 grows = (tfirst < rfirst &&
4348 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4360 else if (max > 0xff)
4365 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4367 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4368 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4369 PAD_SETSV(cPADOPo->op_padix, swash);
4371 SvREADONLY_on(swash);
4373 cSVOPo->op_sv = swash;
4375 SvREFCNT_dec(listsv);
4376 SvREFCNT_dec(transv);
4378 if (!del && havefinal && rlen)
4379 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4380 newSVuv((UV)final), 0);
4383 o->op_private |= OPpTRANS_GROWS;
4389 op_getmad(expr,o,'e');
4390 op_getmad(repl,o,'r');
4398 tbl = (short*)PerlMemShared_calloc(
4399 (o->op_private & OPpTRANS_COMPLEMENT) &&
4400 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4402 cPVOPo->op_pv = (char*)tbl;
4404 for (i = 0; i < (I32)tlen; i++)
4406 for (i = 0, j = 0; i < 256; i++) {
4408 if (j >= (I32)rlen) {
4417 if (i < 128 && r[j] >= 128)
4427 o->op_private |= OPpTRANS_IDENTICAL;
4429 else if (j >= (I32)rlen)
4434 PerlMemShared_realloc(tbl,
4435 (0x101+rlen-j) * sizeof(short));
4436 cPVOPo->op_pv = (char*)tbl;
4438 tbl[0x100] = (short)(rlen - j);
4439 for (i=0; i < (I32)rlen - j; i++)
4440 tbl[0x101+i] = r[j+i];
4444 if (!rlen && !del) {
4447 o->op_private |= OPpTRANS_IDENTICAL;
4449 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4450 o->op_private |= OPpTRANS_IDENTICAL;
4452 for (i = 0; i < 256; i++)
4454 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4455 if (j >= (I32)rlen) {
4457 if (tbl[t[i]] == -1)
4463 if (tbl[t[i]] == -1) {
4464 if (t[i] < 128 && r[j] >= 128)
4471 if(del && rlen == tlen) {
4472 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4473 } else if(rlen > tlen && !complement) {
4474 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4478 o->op_private |= OPpTRANS_GROWS;
4480 op_getmad(expr,o,'e');
4481 op_getmad(repl,o,'r');
4491 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4493 Constructs, checks, and returns an op of any pattern matching type.
4494 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4495 and, shifted up eight bits, the eight bits of C<op_private>.
4501 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4506 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4508 NewOp(1101, pmop, 1, PMOP);
4509 pmop->op_type = (OPCODE)type;
4510 pmop->op_ppaddr = PL_ppaddr[type];
4511 pmop->op_flags = (U8)flags;
4512 pmop->op_private = (U8)(0 | (flags >> 8));
4514 if (PL_hints & HINT_RE_TAINT)
4515 pmop->op_pmflags |= PMf_RETAINT;
4516 if (IN_LOCALE_COMPILETIME) {
4517 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4519 else if ((! (PL_hints & HINT_BYTES))
4520 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4521 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4523 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4525 if (PL_hints & HINT_RE_FLAGS) {
4526 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4527 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4529 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4530 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4531 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4533 if (reflags && SvOK(reflags)) {
4534 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4540 assert(SvPOK(PL_regex_pad[0]));
4541 if (SvCUR(PL_regex_pad[0])) {
4542 /* Pop off the "packed" IV from the end. */
4543 SV *const repointer_list = PL_regex_pad[0];
4544 const char *p = SvEND(repointer_list) - sizeof(IV);
4545 const IV offset = *((IV*)p);
4547 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4549 SvEND_set(repointer_list, p);
4551 pmop->op_pmoffset = offset;
4552 /* This slot should be free, so assert this: */
4553 assert(PL_regex_pad[offset] == &PL_sv_undef);
4555 SV * const repointer = &PL_sv_undef;
4556 av_push(PL_regex_padav, repointer);
4557 pmop->op_pmoffset = av_len(PL_regex_padav);
4558 PL_regex_pad = AvARRAY(PL_regex_padav);
4562 return CHECKOP(type, pmop);
4565 /* Given some sort of match op o, and an expression expr containing a
4566 * pattern, either compile expr into a regex and attach it to o (if it's
4567 * constant), or convert expr into a runtime regcomp op sequence (if it's
4570 * isreg indicates that the pattern is part of a regex construct, eg
4571 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4572 * split "pattern", which aren't. In the former case, expr will be a list
4573 * if the pattern contains more than one term (eg /a$b/) or if it contains
4574 * a replacement, ie s/// or tr///.
4576 * When the pattern has been compiled within a new anon CV (for
4577 * qr/(?{...})/ ), then floor indicates the savestack level just before
4578 * the new sub was created
4582 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4587 I32 repl_has_vars = 0;
4589 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4590 bool is_compiletime;
4593 PERL_ARGS_ASSERT_PMRUNTIME;
4595 /* for s/// and tr///, last element in list is the replacement; pop it */
4597 if (is_trans || o->op_type == OP_SUBST) {
4599 repl = cLISTOPx(expr)->op_last;
4600 kid = cLISTOPx(expr)->op_first;
4601 while (kid->op_sibling != repl)
4602 kid = kid->op_sibling;
4603 kid->op_sibling = NULL;
4604 cLISTOPx(expr)->op_last = kid;
4607 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4610 OP* const oe = expr;
4611 assert(expr->op_type == OP_LIST);
4612 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4613 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4614 expr = cLISTOPx(oe)->op_last;
4615 cLISTOPx(oe)->op_first->op_sibling = NULL;
4616 cLISTOPx(oe)->op_last = NULL;
4619 return pmtrans(o, expr, repl);
4622 /* find whether we have any runtime or code elements;
4623 * at the same time, temporarily set the op_next of each DO block;
4624 * then when we LINKLIST, this will cause the DO blocks to be excluded
4625 * from the op_next chain (and from having LINKLIST recursively
4626 * applied to them). We fix up the DOs specially later */
4630 if (expr->op_type == OP_LIST) {
4632 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4633 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4635 assert(!o->op_next && o->op_sibling);
4636 o->op_next = o->op_sibling;
4638 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4642 else if (expr->op_type != OP_CONST)
4647 /* fix up DO blocks; treat each one as a separate little sub;
4648 * also, mark any arrays as LIST/REF */
4650 if (expr->op_type == OP_LIST) {
4652 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4654 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4655 assert( !(o->op_flags & OPf_WANT));
4656 /* push the array rather than its contents. The regex
4657 * engine will retrieve and join the elements later */
4658 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4662 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4664 o->op_next = NULL; /* undo temporary hack from above */
4667 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4668 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4670 assert(leaveop->op_first->op_type == OP_ENTER);
4671 assert(leaveop->op_first->op_sibling);
4672 o->op_next = leaveop->op_first->op_sibling;
4674 assert(leaveop->op_flags & OPf_KIDS);
4675 assert(leaveop->op_last->op_next == (OP*)leaveop);
4676 leaveop->op_next = NULL; /* stop on last op */
4677 op_null((OP*)leaveop);
4681 OP *scope = cLISTOPo->op_first;
4682 assert(scope->op_type == OP_SCOPE);
4683 assert(scope->op_flags & OPf_KIDS);
4684 scope->op_next = NULL; /* stop on last op */
4687 /* have to peep the DOs individually as we've removed it from
4688 * the op_next chain */
4691 /* runtime finalizes as part of finalizing whole tree */
4695 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4696 assert( !(expr->op_flags & OPf_WANT));
4697 /* push the array rather than its contents. The regex
4698 * engine will retrieve and join the elements later */
4699 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4702 PL_hints |= HINT_BLOCK_SCOPE;
4704 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4706 if (is_compiletime) {
4707 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4708 regexp_engine const *eng = current_re_engine();
4710 if (o->op_flags & OPf_SPECIAL)
4711 rx_flags |= RXf_SPLIT;
4713 if (!has_code || !eng->op_comp) {
4714 /* compile-time simple constant pattern */
4716 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4717 /* whoops! we guessed that a qr// had a code block, but we
4718 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4719 * that isn't required now. Note that we have to be pretty
4720 * confident that nothing used that CV's pad while the
4721 * regex was parsed */
4722 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4723 /* But we know that one op is using this CV's slab. */
4724 cv_forget_slab(PL_compcv);
4726 pm->op_pmflags &= ~PMf_HAS_CV;
4731 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4732 rx_flags, pm->op_pmflags)
4733 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4734 rx_flags, pm->op_pmflags)
4737 op_getmad(expr,(OP*)pm,'e');
4743 /* compile-time pattern that includes literal code blocks */
4744 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4747 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4750 if (pm->op_pmflags & PMf_HAS_CV) {
4752 /* this QR op (and the anon sub we embed it in) is never
4753 * actually executed. It's just a placeholder where we can
4754 * squirrel away expr in op_code_list without the peephole
4755 * optimiser etc processing it for a second time */
4756 OP *qr = newPMOP(OP_QR, 0);
4757 ((PMOP*)qr)->op_code_list = expr;
4759 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4760 SvREFCNT_inc_simple_void(PL_compcv);
4761 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4762 ReANY(re)->qr_anoncv = cv;
4764 /* attach the anon CV to the pad so that
4765 * pad_fixup_inner_anons() can find it */
4766 (void)pad_add_anon(cv, o->op_type);
4767 SvREFCNT_inc_simple_void(cv);
4770 pm->op_code_list = expr;
4775 /* runtime pattern: build chain of regcomp etc ops */
4777 PADOFFSET cv_targ = 0;
4779 reglist = isreg && expr->op_type == OP_LIST;
4784 pm->op_code_list = expr;
4785 /* don't free op_code_list; its ops are embedded elsewhere too */
4786 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4789 if (o->op_flags & OPf_SPECIAL)
4790 pm->op_pmflags |= PMf_SPLIT;
4792 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4793 * to allow its op_next to be pointed past the regcomp and
4794 * preceding stacking ops;
4795 * OP_REGCRESET is there to reset taint before executing the
4797 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4798 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4800 if (pm->op_pmflags & PMf_HAS_CV) {
4801 /* we have a runtime qr with literal code. This means
4802 * that the qr// has been wrapped in a new CV, which
4803 * means that runtime consts, vars etc will have been compiled
4804 * against a new pad. So... we need to execute those ops
4805 * within the environment of the new CV. So wrap them in a call
4806 * to a new anon sub. i.e. for
4810 * we build an anon sub that looks like
4812 * sub { "a", $b, '(?{...})' }
4814 * and call it, passing the returned list to regcomp.
4815 * Or to put it another way, the list of ops that get executed
4819 * ------ -------------------
4820 * pushmark (for regcomp)
4821 * pushmark (for entersub)
4822 * pushmark (for refgen)
4826 * regcreset regcreset
4828 * const("a") const("a")
4830 * const("(?{...})") const("(?{...})")
4835 SvREFCNT_inc_simple_void(PL_compcv);
4836 /* these lines are just an unrolled newANONATTRSUB */
4837 expr = newSVOP(OP_ANONCODE, 0,
4838 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4839 cv_targ = expr->op_targ;
4840 expr = newUNOP(OP_REFGEN, 0, expr);
4842 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4845 NewOp(1101, rcop, 1, LOGOP);
4846 rcop->op_type = OP_REGCOMP;
4847 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4848 rcop->op_first = scalar(expr);
4849 rcop->op_flags |= OPf_KIDS
4850 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4851 | (reglist ? OPf_STACKED : 0);
4852 rcop->op_private = 0;
4854 rcop->op_targ = cv_targ;
4856 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4857 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4859 /* establish postfix order */
4860 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4862 rcop->op_next = expr;
4863 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4866 rcop->op_next = LINKLIST(expr);
4867 expr->op_next = (OP*)rcop;
4870 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4876 /* If we are looking at s//.../e with a single statement, get past
4877 the implicit do{}. */
4878 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4879 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4880 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4881 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4882 if (kid->op_type == OP_NULL && kid->op_sibling
4883 && !kid->op_sibling->op_sibling)
4884 curop = kid->op_sibling;
4886 if (curop->op_type == OP_CONST)
4888 else if (( (curop->op_type == OP_RV2SV ||
4889 curop->op_type == OP_RV2AV ||
4890 curop->op_type == OP_RV2HV ||
4891 curop->op_type == OP_RV2GV)
4892 && cUNOPx(curop)->op_first
4893 && cUNOPx(curop)->op_first->op_type == OP_GV )
4894 || curop->op_type == OP_PADSV
4895 || curop->op_type == OP_PADAV
4896 || curop->op_type == OP_PADHV
4897 || curop->op_type == OP_PADANY) {
4905 || !RX_PRELEN(PM_GETRE(pm))
4906 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4908 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4909 op_prepend_elem(o->op_type, scalar(repl), o);
4912 NewOp(1101, rcop, 1, LOGOP);
4913 rcop->op_type = OP_SUBSTCONT;
4914 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4915 rcop->op_first = scalar(repl);
4916 rcop->op_flags |= OPf_KIDS;
4917 rcop->op_private = 1;
4920 /* establish postfix order */
4921 rcop->op_next = LINKLIST(repl);
4922 repl->op_next = (OP*)rcop;
4924 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4925 assert(!(pm->op_pmflags & PMf_ONCE));
4926 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4935 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4937 Constructs, checks, and returns an op of any type that involves an
4938 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4939 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4940 takes ownership of one reference to it.
4946 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4951 PERL_ARGS_ASSERT_NEWSVOP;
4953 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4954 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4955 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4957 NewOp(1101, svop, 1, SVOP);
4958 svop->op_type = (OPCODE)type;
4959 svop->op_ppaddr = PL_ppaddr[type];
4961 svop->op_next = (OP*)svop;
4962 svop->op_flags = (U8)flags;
4963 svop->op_private = (U8)(0 | (flags >> 8));
4964 if (PL_opargs[type] & OA_RETSCALAR)
4966 if (PL_opargs[type] & OA_TARGET)
4967 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4968 return CHECKOP(type, svop);
4974 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4976 Constructs, checks, and returns an op of any type that involves a
4977 reference to a pad element. I<type> is the opcode. I<flags> gives the
4978 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4979 is populated with I<sv>; this function takes ownership of one reference
4982 This function only exists if Perl has been compiled to use ithreads.
4988 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4993 PERL_ARGS_ASSERT_NEWPADOP;
4995 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4996 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4997 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4999 NewOp(1101, padop, 1, PADOP);
5000 padop->op_type = (OPCODE)type;
5001 padop->op_ppaddr = PL_ppaddr[type];
5002 padop->op_padix = pad_alloc(type, SVs_PADTMP);
5003 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5004 PAD_SETSV(padop->op_padix, sv);
5007 padop->op_next = (OP*)padop;
5008 padop->op_flags = (U8)flags;
5009 if (PL_opargs[type] & OA_RETSCALAR)
5011 if (PL_opargs[type] & OA_TARGET)
5012 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5013 return CHECKOP(type, padop);
5016 #endif /* USE_ITHREADS */
5019 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5021 Constructs, checks, and returns an op of any type that involves an
5022 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5023 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5024 reference; calling this function does not transfer ownership of any
5031 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5035 PERL_ARGS_ASSERT_NEWGVOP;
5039 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5041 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5046 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5048 Constructs, checks, and returns an op of any type that involves an
5049 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5050 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5051 must have been allocated using C<PerlMemShared_malloc>; the memory will
5052 be freed when the op is destroyed.
5058 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5061 const bool utf8 = cBOOL(flags & SVf_UTF8);
5066 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5068 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5070 NewOp(1101, pvop, 1, PVOP);
5071 pvop->op_type = (OPCODE)type;
5072 pvop->op_ppaddr = PL_ppaddr[type];
5074 pvop->op_next = (OP*)pvop;
5075 pvop->op_flags = (U8)flags;
5076 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5077 if (PL_opargs[type] & OA_RETSCALAR)
5079 if (PL_opargs[type] & OA_TARGET)
5080 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5081 return CHECKOP(type, pvop);
5089 Perl_package(pTHX_ OP *o)
5092 SV *const sv = cSVOPo->op_sv;
5097 PERL_ARGS_ASSERT_PACKAGE;
5099 SAVEGENERICSV(PL_curstash);
5100 save_item(PL_curstname);
5102 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5104 sv_setsv(PL_curstname, sv);
5106 PL_hints |= HINT_BLOCK_SCOPE;
5107 PL_parser->copline = NOLINE;
5108 PL_parser->expect = XSTATE;
5113 if (!PL_madskills) {
5118 pegop = newOP(OP_NULL,0);
5119 op_getmad(o,pegop,'P');
5125 Perl_package_version( pTHX_ OP *v )
5128 U32 savehints = PL_hints;
5129 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5130 PL_hints &= ~HINT_STRICT_VARS;
5131 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5132 PL_hints = savehints;
5141 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5148 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5150 SV *use_version = NULL;
5152 PERL_ARGS_ASSERT_UTILIZE;
5154 if (idop->op_type != OP_CONST)
5155 Perl_croak(aTHX_ "Module name must be constant");
5158 op_getmad(idop,pegop,'U');
5163 SV * const vesv = ((SVOP*)version)->op_sv;
5166 op_getmad(version,pegop,'V');
5167 if (!arg && !SvNIOKp(vesv)) {
5174 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5175 Perl_croak(aTHX_ "Version number must be a constant number");
5177 /* Make copy of idop so we don't free it twice */
5178 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5180 /* Fake up a method call to VERSION */
5181 meth = newSVpvs_share("VERSION");
5182 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5183 op_append_elem(OP_LIST,
5184 op_prepend_elem(OP_LIST, pack, list(version)),
5185 newSVOP(OP_METHOD_NAMED, 0, meth)));
5189 /* Fake up an import/unimport */
5190 if (arg && arg->op_type == OP_STUB) {
5192 op_getmad(arg,pegop,'S');
5193 imop = arg; /* no import on explicit () */
5195 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5196 imop = NULL; /* use 5.0; */
5198 use_version = ((SVOP*)idop)->op_sv;
5200 idop->op_private |= OPpCONST_NOVER;
5206 op_getmad(arg,pegop,'A');
5208 /* Make copy of idop so we don't free it twice */
5209 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5211 /* Fake up a method call to import/unimport */
5213 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5214 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5215 op_append_elem(OP_LIST,
5216 op_prepend_elem(OP_LIST, pack, list(arg)),
5217 newSVOP(OP_METHOD_NAMED, 0, meth)));
5220 /* Fake up the BEGIN {}, which does its thing immediately. */
5222 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5225 op_append_elem(OP_LINESEQ,
5226 op_append_elem(OP_LINESEQ,
5227 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5228 newSTATEOP(0, NULL, veop)),
5229 newSTATEOP(0, NULL, imop) ));
5233 * feature bundle that corresponds to the required version. */
5234 use_version = sv_2mortal(new_version(use_version));
5235 S_enable_feature_bundle(aTHX_ use_version);
5237 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5238 if (vcmp(use_version,
5239 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5240 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5241 PL_hints |= HINT_STRICT_REFS;
5242 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5243 PL_hints |= HINT_STRICT_SUBS;
5244 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5245 PL_hints |= HINT_STRICT_VARS;
5247 /* otherwise they are off */
5249 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5250 PL_hints &= ~HINT_STRICT_REFS;
5251 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5252 PL_hints &= ~HINT_STRICT_SUBS;
5253 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5254 PL_hints &= ~HINT_STRICT_VARS;
5258 /* The "did you use incorrect case?" warning used to be here.
5259 * The problem is that on case-insensitive filesystems one
5260 * might get false positives for "use" (and "require"):
5261 * "use Strict" or "require CARP" will work. This causes
5262 * portability problems for the script: in case-strict
5263 * filesystems the script will stop working.
5265 * The "incorrect case" warning checked whether "use Foo"
5266 * imported "Foo" to your namespace, but that is wrong, too:
5267 * there is no requirement nor promise in the language that
5268 * a Foo.pm should or would contain anything in package "Foo".
5270 * There is very little Configure-wise that can be done, either:
5271 * the case-sensitivity of the build filesystem of Perl does not
5272 * help in guessing the case-sensitivity of the runtime environment.
5275 PL_hints |= HINT_BLOCK_SCOPE;
5276 PL_parser->copline = NOLINE;
5277 PL_parser->expect = XSTATE;
5278 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5279 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5288 =head1 Embedding Functions
5290 =for apidoc load_module
5292 Loads the module whose name is pointed to by the string part of name.
5293 Note that the actual module name, not its filename, should be given.
5294 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5295 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5296 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5297 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5298 arguments can be used to specify arguments to the module's import()
5299 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5300 terminated with a final NULL pointer. Note that this list can only
5301 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5302 Otherwise at least a single NULL pointer to designate the default
5303 import list is required.
5305 The reference count for each specified C<SV*> parameter is decremented.
5310 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5314 PERL_ARGS_ASSERT_LOAD_MODULE;
5316 va_start(args, ver);
5317 vload_module(flags, name, ver, &args);
5321 #ifdef PERL_IMPLICIT_CONTEXT
5323 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5327 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5328 va_start(args, ver);
5329 vload_module(flags, name, ver, &args);
5335 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5339 OP * const modname = newSVOP(OP_CONST, 0, name);
5341 PERL_ARGS_ASSERT_VLOAD_MODULE;
5343 modname->op_private |= OPpCONST_BARE;
5345 veop = newSVOP(OP_CONST, 0, ver);
5349 if (flags & PERL_LOADMOD_NOIMPORT) {
5350 imop = sawparens(newNULLLIST());
5352 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5353 imop = va_arg(*args, OP*);
5358 sv = va_arg(*args, SV*);
5360 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5361 sv = va_arg(*args, SV*);
5365 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5366 * that it has a PL_parser to play with while doing that, and also
5367 * that it doesn't mess with any existing parser, by creating a tmp
5368 * new parser with lex_start(). This won't actually be used for much,
5369 * since pp_require() will create another parser for the real work. */
5372 SAVEVPTR(PL_curcop);
5373 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5374 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5375 veop, modname, imop);
5380 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5386 PERL_ARGS_ASSERT_DOFILE;
5388 if (!force_builtin) {
5389 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5390 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5391 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5392 gv = gvp ? *gvp : NULL;
5396 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5397 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5398 op_append_elem(OP_LIST, term,
5399 scalar(newUNOP(OP_RV2CV, 0,
5400 newGVOP(OP_GV, 0, gv)))));
5403 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5409 =head1 Optree construction
5411 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5413 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5414 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5415 be set automatically, and, shifted up eight bits, the eight bits of
5416 C<op_private>, except that the bit with value 1 or 2 is automatically
5417 set as required. I<listval> and I<subscript> supply the parameters of
5418 the slice; they are consumed by this function and become part of the
5419 constructed op tree.
5425 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5427 return newBINOP(OP_LSLICE, flags,
5428 list(force_list(subscript)),
5429 list(force_list(listval)) );
5433 S_is_list_assignment(pTHX_ const OP *o)
5441 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5442 o = cUNOPo->op_first;
5444 flags = o->op_flags;
5446 if (type == OP_COND_EXPR) {
5447 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5448 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5453 yyerror("Assignment to both a list and a scalar");
5457 if (type == OP_LIST &&
5458 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5459 o->op_private & OPpLVAL_INTRO)
5462 if (type == OP_LIST || flags & OPf_PARENS ||
5463 type == OP_RV2AV || type == OP_RV2HV ||
5464 type == OP_ASLICE || type == OP_HSLICE ||
5465 type == OP_KVASLICE || type == OP_KVHSLICE)
5468 if (type == OP_PADAV || type == OP_PADHV)
5471 if (type == OP_RV2SV)
5478 Helper function for newASSIGNOP to detection commonality between the
5479 lhs and the rhs. Marks all variables with PL_generation. If it
5480 returns TRUE the assignment must be able to handle common variables.
5482 PERL_STATIC_INLINE bool
5483 S_aassign_common_vars(pTHX_ OP* o)
5486 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5487 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5488 if (curop->op_type == OP_GV) {
5489 GV *gv = cGVOPx_gv(curop);
5491 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5493 GvASSIGN_GENERATION_set(gv, PL_generation);
5495 else if (curop->op_type == OP_PADSV ||
5496 curop->op_type == OP_PADAV ||
5497 curop->op_type == OP_PADHV ||
5498 curop->op_type == OP_PADANY)
5500 if (PAD_COMPNAME_GEN(curop->op_targ)
5501 == (STRLEN)PL_generation)
5503 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5506 else if (curop->op_type == OP_RV2CV)
5508 else if (curop->op_type == OP_RV2SV ||
5509 curop->op_type == OP_RV2AV ||
5510 curop->op_type == OP_RV2HV ||
5511 curop->op_type == OP_RV2GV) {
5512 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5515 else if (curop->op_type == OP_PUSHRE) {
5518 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5519 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5522 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5526 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5528 GvASSIGN_GENERATION_set(gv, PL_generation);
5535 if (curop->op_flags & OPf_KIDS) {
5536 if (aassign_common_vars(curop))
5544 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5546 Constructs, checks, and returns an assignment op. I<left> and I<right>
5547 supply the parameters of the assignment; they are consumed by this
5548 function and become part of the constructed op tree.
5550 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5551 a suitable conditional optree is constructed. If I<optype> is the opcode
5552 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5553 performs the binary operation and assigns the result to the left argument.
5554 Either way, if I<optype> is non-zero then I<flags> has no effect.
5556 If I<optype> is zero, then a plain scalar or list assignment is
5557 constructed. Which type of assignment it is is automatically determined.
5558 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5559 will be set automatically, and, shifted up eight bits, the eight bits
5560 of C<op_private>, except that the bit with value 1 or 2 is automatically
5567 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5573 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5574 return newLOGOP(optype, 0,
5575 op_lvalue(scalar(left), optype),
5576 newUNOP(OP_SASSIGN, 0, scalar(right)));
5579 return newBINOP(optype, OPf_STACKED,
5580 op_lvalue(scalar(left), optype), scalar(right));
5584 if (is_list_assignment(left)) {
5585 static const char no_list_state[] = "Initialization of state variables"
5586 " in list context currently forbidden";
5588 bool maybe_common_vars = TRUE;
5590 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5591 left->op_private &= ~ OPpSLICEWARNING;
5594 left = op_lvalue(left, OP_AASSIGN);
5595 curop = list(force_list(left));
5596 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5597 o->op_private = (U8)(0 | (flags >> 8));
5599 if ((left->op_type == OP_LIST
5600 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5602 OP* lop = ((LISTOP*)left)->op_first;
5603 maybe_common_vars = FALSE;
5605 if (lop->op_type == OP_PADSV ||
5606 lop->op_type == OP_PADAV ||
5607 lop->op_type == OP_PADHV ||
5608 lop->op_type == OP_PADANY) {
5609 if (!(lop->op_private & OPpLVAL_INTRO))
5610 maybe_common_vars = TRUE;
5612 if (lop->op_private & OPpPAD_STATE) {
5613 if (left->op_private & OPpLVAL_INTRO) {
5614 /* Each variable in state($a, $b, $c) = ... */
5617 /* Each state variable in
5618 (state $a, my $b, our $c, $d, undef) = ... */
5620 yyerror(no_list_state);
5622 /* Each my variable in
5623 (state $a, my $b, our $c, $d, undef) = ... */
5625 } else if (lop->op_type == OP_UNDEF ||
5626 lop->op_type == OP_PUSHMARK) {
5627 /* undef may be interesting in
5628 (state $a, undef, state $c) */
5630 /* Other ops in the list. */
5631 maybe_common_vars = TRUE;
5633 lop = lop->op_sibling;
5636 else if ((left->op_private & OPpLVAL_INTRO)
5637 && ( left->op_type == OP_PADSV
5638 || left->op_type == OP_PADAV
5639 || left->op_type == OP_PADHV
5640 || left->op_type == OP_PADANY))
5642 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5643 if (left->op_private & OPpPAD_STATE) {
5644 /* All single variable list context state assignments, hence
5654 yyerror(no_list_state);
5658 /* PL_generation sorcery:
5659 * an assignment like ($a,$b) = ($c,$d) is easier than
5660 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5661 * To detect whether there are common vars, the global var
5662 * PL_generation is incremented for each assign op we compile.
5663 * Then, while compiling the assign op, we run through all the
5664 * variables on both sides of the assignment, setting a spare slot
5665 * in each of them to PL_generation. If any of them already have
5666 * that value, we know we've got commonality. We could use a
5667 * single bit marker, but then we'd have to make 2 passes, first
5668 * to clear the flag, then to test and set it. To find somewhere
5669 * to store these values, evil chicanery is done with SvUVX().
5672 if (maybe_common_vars) {
5674 if (aassign_common_vars(o))
5675 o->op_private |= OPpASSIGN_COMMON;
5679 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5680 OP* tmpop = ((LISTOP*)right)->op_first;
5681 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5682 PMOP * const pm = (PMOP*)tmpop;
5683 if (left->op_type == OP_RV2AV &&
5684 !(left->op_private & OPpLVAL_INTRO) &&
5685 !(o->op_private & OPpASSIGN_COMMON) )
5687 tmpop = ((UNOP*)left)->op_first;
5688 if (tmpop->op_type == OP_GV
5690 && !pm->op_pmreplrootu.op_pmtargetoff
5692 && !pm->op_pmreplrootu.op_pmtargetgv
5696 pm->op_pmreplrootu.op_pmtargetoff
5697 = cPADOPx(tmpop)->op_padix;
5698 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5700 pm->op_pmreplrootu.op_pmtargetgv
5701 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5702 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5704 tmpop = cUNOPo->op_first; /* to list (nulled) */
5705 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5706 tmpop->op_sibling = NULL; /* don't free split */
5707 right->op_next = tmpop->op_next; /* fix starting loc */
5708 op_free(o); /* blow off assign */
5709 right->op_flags &= ~OPf_WANT;
5710 /* "I don't know and I don't care." */
5715 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5716 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5719 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5720 SV * const sv = *svp;
5721 if (SvIOK(sv) && SvIVX(sv) == 0)
5723 if (right->op_private & OPpSPLIT_IMPLIM) {
5724 /* our own SV, created in ck_split */
5726 sv_setiv(sv, PL_modcount+1);
5729 /* SV may belong to someone else */
5731 *svp = newSViv(PL_modcount+1);
5741 right = newOP(OP_UNDEF, 0);
5742 if (right->op_type == OP_READLINE) {
5743 right->op_flags |= OPf_STACKED;
5744 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5748 o = newBINOP(OP_SASSIGN, flags,
5749 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5755 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5757 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5758 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5759 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5760 If I<label> is non-null, it supplies the name of a label to attach to
5761 the state op; this function takes ownership of the memory pointed at by
5762 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5765 If I<o> is null, the state op is returned. Otherwise the state op is
5766 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5767 is consumed by this function and becomes part of the returned op tree.
5773 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5776 const U32 seq = intro_my();
5777 const U32 utf8 = flags & SVf_UTF8;
5782 NewOp(1101, cop, 1, COP);
5783 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5784 cop->op_type = OP_DBSTATE;
5785 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5788 cop->op_type = OP_NEXTSTATE;
5789 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5791 cop->op_flags = (U8)flags;
5792 CopHINTS_set(cop, PL_hints);
5794 cop->op_private |= NATIVE_HINTS;
5796 cop->op_next = (OP*)cop;
5799 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5800 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5802 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5804 PL_hints |= HINT_BLOCK_SCOPE;
5805 /* It seems that we need to defer freeing this pointer, as other parts
5806 of the grammar end up wanting to copy it after this op has been
5811 if (PL_parser->preambling != NOLINE) {
5812 CopLINE_set(cop, PL_parser->preambling);
5813 PL_parser->copline = NOLINE;
5815 else if (PL_parser->copline == NOLINE)
5816 CopLINE_set(cop, CopLINE(PL_curcop));
5818 CopLINE_set(cop, PL_parser->copline);
5819 PL_parser->copline = NOLINE;
5822 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5824 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5826 CopSTASH_set(cop, PL_curstash);
5828 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5829 /* this line can have a breakpoint - store the cop in IV */
5830 AV *av = CopFILEAVx(PL_curcop);
5832 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5833 if (svp && *svp != &PL_sv_undef ) {
5834 (void)SvIOK_on(*svp);
5835 SvIV_set(*svp, PTR2IV(cop));
5840 if (flags & OPf_SPECIAL)
5842 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5846 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5848 Constructs, checks, and returns a logical (flow control) op. I<type>
5849 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5850 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5851 the eight bits of C<op_private>, except that the bit with value 1 is
5852 automatically set. I<first> supplies the expression controlling the
5853 flow, and I<other> supplies the side (alternate) chain of ops; they are
5854 consumed by this function and become part of the constructed op tree.
5860 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5864 PERL_ARGS_ASSERT_NEWLOGOP;
5866 return new_logop(type, flags, &first, &other);
5870 S_search_const(pTHX_ OP *o)
5872 PERL_ARGS_ASSERT_SEARCH_CONST;
5874 switch (o->op_type) {
5878 if (o->op_flags & OPf_KIDS)
5879 return search_const(cUNOPo->op_first);
5886 if (!(o->op_flags & OPf_KIDS))
5888 kid = cLISTOPo->op_first;
5890 switch (kid->op_type) {
5894 kid = kid->op_sibling;
5897 if (kid != cLISTOPo->op_last)
5903 kid = cLISTOPo->op_last;
5905 return search_const(kid);
5913 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5921 int prepend_not = 0;
5923 PERL_ARGS_ASSERT_NEW_LOGOP;
5928 /* [perl #59802]: Warn about things like "return $a or $b", which
5929 is parsed as "(return $a) or $b" rather than "return ($a or
5930 $b)". NB: This also applies to xor, which is why we do it
5933 switch (first->op_type) {
5937 /* XXX: Perhaps we should emit a stronger warning for these.
5938 Even with the high-precedence operator they don't seem to do
5941 But until we do, fall through here.
5947 /* XXX: Currently we allow people to "shoot themselves in the
5948 foot" by explicitly writing "(return $a) or $b".
5950 Warn unless we are looking at the result from folding or if
5951 the programmer explicitly grouped the operators like this.
5952 The former can occur with e.g.
5954 use constant FEATURE => ( $] >= ... );
5955 sub { not FEATURE and return or do_stuff(); }
5957 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
5958 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
5959 "Possible precedence issue with control flow operator");
5960 /* XXX: Should we optimze this to "return $a;" (i.e. remove
5966 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5967 return newBINOP(type, flags, scalar(first), scalar(other));
5969 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5971 scalarboolean(first);
5972 /* optimize AND and OR ops that have NOTs as children */
5973 if (first->op_type == OP_NOT
5974 && (first->op_flags & OPf_KIDS)
5975 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5976 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5978 if (type == OP_AND || type == OP_OR) {
5984 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5986 prepend_not = 1; /* prepend a NOT op later */
5990 /* search for a constant op that could let us fold the test */
5991 if ((cstop = search_const(first))) {
5992 if (cstop->op_private & OPpCONST_STRICT)
5993 no_bareword_allowed(cstop);
5994 else if ((cstop->op_private & OPpCONST_BARE))
5995 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5996 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5997 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5998 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6000 if (other->op_type == OP_CONST)
6001 other->op_private |= OPpCONST_SHORTCIRCUIT;
6003 OP *newop = newUNOP(OP_NULL, 0, other);
6004 op_getmad(first, newop, '1');
6005 newop->op_targ = type; /* set "was" field */
6009 if (other->op_type == OP_LEAVE)
6010 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6011 else if (other->op_type == OP_MATCH
6012 || other->op_type == OP_SUBST
6013 || other->op_type == OP_TRANSR
6014 || other->op_type == OP_TRANS)
6015 /* Mark the op as being unbindable with =~ */
6016 other->op_flags |= OPf_SPECIAL;
6018 other->op_folded = 1;
6022 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6023 const OP *o2 = other;
6024 if ( ! (o2->op_type == OP_LIST
6025 && (( o2 = cUNOPx(o2)->op_first))
6026 && o2->op_type == OP_PUSHMARK
6027 && (( o2 = o2->op_sibling)) )
6030 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6031 || o2->op_type == OP_PADHV)
6032 && o2->op_private & OPpLVAL_INTRO
6033 && !(o2->op_private & OPpPAD_STATE))
6035 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6036 "Deprecated use of my() in false conditional");
6040 if (cstop->op_type == OP_CONST)
6041 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6043 first = newUNOP(OP_NULL, 0, first);
6044 op_getmad(other, first, '2');
6045 first->op_targ = type; /* set "was" field */
6052 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6053 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6055 const OP * const k1 = ((UNOP*)first)->op_first;
6056 const OP * const k2 = k1->op_sibling;
6058 switch (first->op_type)
6061 if (k2 && k2->op_type == OP_READLINE
6062 && (k2->op_flags & OPf_STACKED)
6063 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6065 warnop = k2->op_type;
6070 if (k1->op_type == OP_READDIR
6071 || k1->op_type == OP_GLOB
6072 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6073 || k1->op_type == OP_EACH
6074 || k1->op_type == OP_AEACH)
6076 warnop = ((k1->op_type == OP_NULL)
6077 ? (OPCODE)k1->op_targ : k1->op_type);
6082 const line_t oldline = CopLINE(PL_curcop);
6083 /* This ensures that warnings are reported at the first line
6084 of the construction, not the last. */
6085 CopLINE_set(PL_curcop, PL_parser->copline);
6086 Perl_warner(aTHX_ packWARN(WARN_MISC),
6087 "Value of %s%s can be \"0\"; test with defined()",
6089 ((warnop == OP_READLINE || warnop == OP_GLOB)
6090 ? " construct" : "() operator"));
6091 CopLINE_set(PL_curcop, oldline);
6098 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6099 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6101 NewOp(1101, logop, 1, LOGOP);
6103 logop->op_type = (OPCODE)type;
6104 logop->op_ppaddr = PL_ppaddr[type];
6105 logop->op_first = first;
6106 logop->op_flags = (U8)(flags | OPf_KIDS);
6107 logop->op_other = LINKLIST(other);
6108 logop->op_private = (U8)(1 | (flags >> 8));
6110 /* establish postfix order */
6111 logop->op_next = LINKLIST(first);
6112 first->op_next = (OP*)logop;
6113 first->op_sibling = other;
6115 CHECKOP(type,logop);
6117 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6124 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6126 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6127 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6128 will be set automatically, and, shifted up eight bits, the eight bits of
6129 C<op_private>, except that the bit with value 1 is automatically set.
6130 I<first> supplies the expression selecting between the two branches,
6131 and I<trueop> and I<falseop> supply the branches; they are consumed by
6132 this function and become part of the constructed op tree.
6138 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6146 PERL_ARGS_ASSERT_NEWCONDOP;
6149 return newLOGOP(OP_AND, 0, first, trueop);
6151 return newLOGOP(OP_OR, 0, first, falseop);
6153 scalarboolean(first);
6154 if ((cstop = search_const(first))) {
6155 /* Left or right arm of the conditional? */
6156 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6157 OP *live = left ? trueop : falseop;
6158 OP *const dead = left ? falseop : trueop;
6159 if (cstop->op_private & OPpCONST_BARE &&
6160 cstop->op_private & OPpCONST_STRICT) {
6161 no_bareword_allowed(cstop);
6164 /* This is all dead code when PERL_MAD is not defined. */
6165 live = newUNOP(OP_NULL, 0, live);
6166 op_getmad(first, live, 'C');
6167 op_getmad(dead, live, left ? 'e' : 't');
6172 if (live->op_type == OP_LEAVE)
6173 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6174 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6175 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6176 /* Mark the op as being unbindable with =~ */
6177 live->op_flags |= OPf_SPECIAL;
6178 live->op_folded = 1;
6181 NewOp(1101, logop, 1, LOGOP);
6182 logop->op_type = OP_COND_EXPR;
6183 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6184 logop->op_first = first;
6185 logop->op_flags = (U8)(flags | OPf_KIDS);
6186 logop->op_private = (U8)(1 | (flags >> 8));
6187 logop->op_other = LINKLIST(trueop);
6188 logop->op_next = LINKLIST(falseop);
6190 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6193 /* establish postfix order */
6194 start = LINKLIST(first);
6195 first->op_next = (OP*)logop;
6197 first->op_sibling = trueop;
6198 trueop->op_sibling = falseop;
6199 o = newUNOP(OP_NULL, 0, (OP*)logop);
6201 trueop->op_next = falseop->op_next = o;
6208 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6210 Constructs and returns a C<range> op, with subordinate C<flip> and
6211 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6212 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6213 for both the C<flip> and C<range> ops, except that the bit with value
6214 1 is automatically set. I<left> and I<right> supply the expressions
6215 controlling the endpoints of the range; they are consumed by this function
6216 and become part of the constructed op tree.
6222 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6231 PERL_ARGS_ASSERT_NEWRANGE;
6233 NewOp(1101, range, 1, LOGOP);
6235 range->op_type = OP_RANGE;
6236 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6237 range->op_first = left;
6238 range->op_flags = OPf_KIDS;
6239 leftstart = LINKLIST(left);
6240 range->op_other = LINKLIST(right);
6241 range->op_private = (U8)(1 | (flags >> 8));
6243 left->op_sibling = right;
6245 range->op_next = (OP*)range;
6246 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6247 flop = newUNOP(OP_FLOP, 0, flip);
6248 o = newUNOP(OP_NULL, 0, flop);
6250 range->op_next = leftstart;
6252 left->op_next = flip;
6253 right->op_next = flop;
6255 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6256 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6257 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6258 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6260 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6261 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6263 /* check barewords before they might be optimized aways */
6264 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6265 no_bareword_allowed(left);
6266 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6267 no_bareword_allowed(right);
6270 if (!flip->op_private || !flop->op_private)
6271 LINKLIST(o); /* blow off optimizer unless constant */
6277 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6279 Constructs, checks, and returns an op tree expressing a loop. This is
6280 only a loop in the control flow through the op tree; it does not have
6281 the heavyweight loop structure that allows exiting the loop by C<last>
6282 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6283 top-level op, except that some bits will be set automatically as required.
6284 I<expr> supplies the expression controlling loop iteration, and I<block>
6285 supplies the body of the loop; they are consumed by this function and
6286 become part of the constructed op tree. I<debuggable> is currently
6287 unused and should always be 1.
6293 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6298 const bool once = block && block->op_flags & OPf_SPECIAL &&
6299 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6301 PERL_UNUSED_ARG(debuggable);
6304 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6305 return block; /* do {} while 0 does once */
6306 if (expr->op_type == OP_READLINE
6307 || expr->op_type == OP_READDIR
6308 || expr->op_type == OP_GLOB
6309 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6310 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6311 expr = newUNOP(OP_DEFINED, 0,
6312 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6313 } else if (expr->op_flags & OPf_KIDS) {
6314 const OP * const k1 = ((UNOP*)expr)->op_first;
6315 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6316 switch (expr->op_type) {
6318 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6319 && (k2->op_flags & OPf_STACKED)
6320 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6321 expr = newUNOP(OP_DEFINED, 0, expr);
6325 if (k1 && (k1->op_type == OP_READDIR
6326 || k1->op_type == OP_GLOB
6327 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6328 || k1->op_type == OP_EACH
6329 || k1->op_type == OP_AEACH))
6330 expr = newUNOP(OP_DEFINED, 0, expr);
6336 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6337 * op, in listop. This is wrong. [perl #27024] */
6339 block = newOP(OP_NULL, 0);
6340 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6341 o = new_logop(OP_AND, 0, &expr, &listop);
6344 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6346 if (once && o != listop)
6347 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6350 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6352 o->op_flags |= flags;
6354 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6359 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6361 Constructs, checks, and returns an op tree expressing a C<while> loop.
6362 This is a heavyweight loop, with structure that allows exiting the loop
6363 by C<last> and suchlike.
6365 I<loop> is an optional preconstructed C<enterloop> op to use in the
6366 loop; if it is null then a suitable op will be constructed automatically.
6367 I<expr> supplies the loop's controlling expression. I<block> supplies the
6368 main body of the loop, and I<cont> optionally supplies a C<continue> block
6369 that operates as a second half of the body. All of these optree inputs
6370 are consumed by this function and become part of the constructed op tree.
6372 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6373 op and, shifted up eight bits, the eight bits of C<op_private> for
6374 the C<leaveloop> op, except that (in both cases) some bits will be set
6375 automatically. I<debuggable> is currently unused and should always be 1.
6376 I<has_my> can be supplied as true to force the
6377 loop body to be enclosed in its own scope.
6383 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6384 OP *expr, OP *block, OP *cont, I32 has_my)
6393 PERL_UNUSED_ARG(debuggable);
6396 if (expr->op_type == OP_READLINE
6397 || expr->op_type == OP_READDIR
6398 || expr->op_type == OP_GLOB
6399 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6400 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6401 expr = newUNOP(OP_DEFINED, 0,
6402 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6403 } else if (expr->op_flags & OPf_KIDS) {
6404 const OP * const k1 = ((UNOP*)expr)->op_first;
6405 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6406 switch (expr->op_type) {
6408 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6409 && (k2->op_flags & OPf_STACKED)
6410 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6411 expr = newUNOP(OP_DEFINED, 0, expr);
6415 if (k1 && (k1->op_type == OP_READDIR
6416 || k1->op_type == OP_GLOB
6417 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6418 || k1->op_type == OP_EACH
6419 || k1->op_type == OP_AEACH))
6420 expr = newUNOP(OP_DEFINED, 0, expr);
6427 block = newOP(OP_NULL, 0);
6428 else if (cont || has_my) {
6429 block = op_scope(block);
6433 next = LINKLIST(cont);
6436 OP * const unstack = newOP(OP_UNSTACK, 0);
6439 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6443 listop = op_append_list(OP_LINESEQ, block, cont);
6445 redo = LINKLIST(listop);
6449 o = new_logop(OP_AND, 0, &expr, &listop);
6450 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6452 return expr; /* listop already freed by new_logop */
6455 ((LISTOP*)listop)->op_last->op_next =
6456 (o == listop ? redo : LINKLIST(o));
6462 NewOp(1101,loop,1,LOOP);
6463 loop->op_type = OP_ENTERLOOP;
6464 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6465 loop->op_private = 0;
6466 loop->op_next = (OP*)loop;
6469 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6471 loop->op_redoop = redo;
6472 loop->op_lastop = o;
6473 o->op_private |= loopflags;
6476 loop->op_nextop = next;
6478 loop->op_nextop = o;
6480 o->op_flags |= flags;
6481 o->op_private |= (flags >> 8);
6486 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6488 Constructs, checks, and returns an op tree expressing a C<foreach>
6489 loop (iteration through a list of values). This is a heavyweight loop,
6490 with structure that allows exiting the loop by C<last> and suchlike.
6492 I<sv> optionally supplies the variable that will be aliased to each
6493 item in turn; if null, it defaults to C<$_> (either lexical or global).
6494 I<expr> supplies the list of values to iterate over. I<block> supplies
6495 the main body of the loop, and I<cont> optionally supplies a C<continue>
6496 block that operates as a second half of the body. All of these optree
6497 inputs are consumed by this function and become part of the constructed
6500 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6501 op and, shifted up eight bits, the eight bits of C<op_private> for
6502 the C<leaveloop> op, except that (in both cases) some bits will be set
6509 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6514 PADOFFSET padoff = 0;
6519 PERL_ARGS_ASSERT_NEWFOROP;
6522 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6523 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6524 sv->op_type = OP_RV2GV;
6525 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6527 /* The op_type check is needed to prevent a possible segfault
6528 * if the loop variable is undeclared and 'strict vars' is in
6529 * effect. This is illegal but is nonetheless parsed, so we
6530 * may reach this point with an OP_CONST where we're expecting
6533 if (cUNOPx(sv)->op_first->op_type == OP_GV
6534 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6535 iterpflags |= OPpITER_DEF;
6537 else if (sv->op_type == OP_PADSV) { /* private variable */
6538 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6539 padoff = sv->op_targ;
6549 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6551 SV *const namesv = PAD_COMPNAME_SV(padoff);
6553 const char *const name = SvPV_const(namesv, len);
6555 if (len == 2 && name[0] == '$' && name[1] == '_')
6556 iterpflags |= OPpITER_DEF;
6560 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6561 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6562 sv = newGVOP(OP_GV, 0, PL_defgv);
6567 iterpflags |= OPpITER_DEF;
6569 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6570 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6571 iterflags |= OPf_STACKED;
6573 else if (expr->op_type == OP_NULL &&
6574 (expr->op_flags & OPf_KIDS) &&
6575 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6577 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6578 * set the STACKED flag to indicate that these values are to be
6579 * treated as min/max values by 'pp_enteriter'.
6581 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6582 LOGOP* const range = (LOGOP*) flip->op_first;
6583 OP* const left = range->op_first;
6584 OP* const right = left->op_sibling;
6587 range->op_flags &= ~OPf_KIDS;
6588 range->op_first = NULL;
6590 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6591 listop->op_first->op_next = range->op_next;
6592 left->op_next = range->op_other;
6593 right->op_next = (OP*)listop;
6594 listop->op_next = listop->op_first;
6597 op_getmad(expr,(OP*)listop,'O');
6601 expr = (OP*)(listop);
6603 iterflags |= OPf_STACKED;
6606 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6609 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6610 op_append_elem(OP_LIST, expr, scalar(sv))));
6611 assert(!loop->op_next);
6612 /* for my $x () sets OPpLVAL_INTRO;
6613 * for our $x () sets OPpOUR_INTRO */
6614 loop->op_private = (U8)iterpflags;
6615 if (loop->op_slabbed
6616 && DIFF(loop, OpSLOT(loop)->opslot_next)
6617 < SIZE_TO_PSIZE(sizeof(LOOP)))
6620 NewOp(1234,tmp,1,LOOP);
6621 Copy(loop,tmp,1,LISTOP);
6622 S_op_destroy(aTHX_ (OP*)loop);
6625 else if (!loop->op_slabbed)
6626 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6627 loop->op_targ = padoff;
6628 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6630 op_getmad(madsv, (OP*)loop, 'v');
6635 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6637 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6638 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6639 determining the target of the op; it is consumed by this function and
6640 becomes part of the constructed op tree.
6646 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6651 PERL_ARGS_ASSERT_NEWLOOPEX;
6653 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6655 if (type != OP_GOTO) {
6656 /* "last()" means "last" */
6657 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6658 o = newOP(type, OPf_SPECIAL);
6662 /* Check whether it's going to be a goto &function */
6663 if (label->op_type == OP_ENTERSUB
6664 && !(label->op_flags & OPf_STACKED))
6665 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6668 /* Check for a constant argument */
6669 if (label->op_type == OP_CONST) {
6670 SV * const sv = ((SVOP *)label)->op_sv;
6672 const char *s = SvPV_const(sv,l);
6673 if (l == strlen(s)) {
6675 SvUTF8(((SVOP*)label)->op_sv),
6677 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6681 /* If we have already created an op, we do not need the label. */
6684 op_getmad(label,o,'L');
6688 else o = newUNOP(type, OPf_STACKED, label);
6690 PL_hints |= HINT_BLOCK_SCOPE;
6694 /* if the condition is a literal array or hash
6695 (or @{ ... } etc), make a reference to it.
6698 S_ref_array_or_hash(pTHX_ OP *cond)
6701 && (cond->op_type == OP_RV2AV
6702 || cond->op_type == OP_PADAV
6703 || cond->op_type == OP_RV2HV
6704 || cond->op_type == OP_PADHV))
6706 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6709 && (cond->op_type == OP_ASLICE
6710 || cond->op_type == OP_KVASLICE
6711 || cond->op_type == OP_HSLICE
6712 || cond->op_type == OP_KVHSLICE)) {
6714 /* anonlist now needs a list from this op, was previously used in
6716 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6717 cond->op_flags |= OPf_WANT_LIST;
6719 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6726 /* These construct the optree fragments representing given()
6729 entergiven and enterwhen are LOGOPs; the op_other pointer
6730 points up to the associated leave op. We need this so we
6731 can put it in the context and make break/continue work.
6732 (Also, of course, pp_enterwhen will jump straight to
6733 op_other if the match fails.)
6737 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6738 I32 enter_opcode, I32 leave_opcode,
6739 PADOFFSET entertarg)
6745 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6747 NewOp(1101, enterop, 1, LOGOP);
6748 enterop->op_type = (Optype)enter_opcode;
6749 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6750 enterop->op_flags = (U8) OPf_KIDS;
6751 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6752 enterop->op_private = 0;
6754 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6757 enterop->op_first = scalar(cond);
6758 cond->op_sibling = block;
6760 o->op_next = LINKLIST(cond);
6761 cond->op_next = (OP *) enterop;
6764 /* This is a default {} block */
6765 enterop->op_first = block;
6766 enterop->op_flags |= OPf_SPECIAL;
6767 o ->op_flags |= OPf_SPECIAL;
6769 o->op_next = (OP *) enterop;
6772 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6773 entergiven and enterwhen both
6776 enterop->op_next = LINKLIST(block);
6777 block->op_next = enterop->op_other = o;
6782 /* Does this look like a boolean operation? For these purposes
6783 a boolean operation is:
6784 - a subroutine call [*]
6785 - a logical connective
6786 - a comparison operator
6787 - a filetest operator, with the exception of -s -M -A -C
6788 - defined(), exists() or eof()
6789 - /$re/ or $foo =~ /$re/
6791 [*] possibly surprising
6794 S_looks_like_bool(pTHX_ const OP *o)
6798 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6800 switch(o->op_type) {
6803 return looks_like_bool(cLOGOPo->op_first);
6807 looks_like_bool(cLOGOPo->op_first)
6808 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6813 o->op_flags & OPf_KIDS
6814 && looks_like_bool(cUNOPo->op_first));
6818 case OP_NOT: case OP_XOR:
6820 case OP_EQ: case OP_NE: case OP_LT:
6821 case OP_GT: case OP_LE: case OP_GE:
6823 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6824 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6826 case OP_SEQ: case OP_SNE: case OP_SLT:
6827 case OP_SGT: case OP_SLE: case OP_SGE:
6831 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6832 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6833 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6834 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6835 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6836 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6837 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6838 case OP_FTTEXT: case OP_FTBINARY:
6840 case OP_DEFINED: case OP_EXISTS:
6841 case OP_MATCH: case OP_EOF:
6848 /* Detect comparisons that have been optimized away */
6849 if (cSVOPo->op_sv == &PL_sv_yes
6850 || cSVOPo->op_sv == &PL_sv_no)
6863 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6865 Constructs, checks, and returns an op tree expressing a C<given> block.
6866 I<cond> supplies the expression that will be locally assigned to a lexical
6867 variable, and I<block> supplies the body of the C<given> construct; they
6868 are consumed by this function and become part of the constructed op tree.
6869 I<defsv_off> is the pad offset of the scalar lexical variable that will
6870 be affected. If it is 0, the global $_ will be used.
6876 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6879 PERL_ARGS_ASSERT_NEWGIVENOP;
6880 return newGIVWHENOP(
6881 ref_array_or_hash(cond),
6883 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6888 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6890 Constructs, checks, and returns an op tree expressing a C<when> block.
6891 I<cond> supplies the test expression, and I<block> supplies the block
6892 that will be executed if the test evaluates to true; they are consumed
6893 by this function and become part of the constructed op tree. I<cond>
6894 will be interpreted DWIMically, often as a comparison against C<$_>,
6895 and may be null to generate a C<default> block.
6901 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6903 const bool cond_llb = (!cond || looks_like_bool(cond));
6906 PERL_ARGS_ASSERT_NEWWHENOP;
6911 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6913 scalar(ref_array_or_hash(cond)));
6916 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6920 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6921 const STRLEN len, const U32 flags)
6923 SV *name = NULL, *msg;
6924 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
6925 STRLEN clen = CvPROTOLEN(cv), plen = len;
6927 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6929 if (p == NULL && cvp == NULL)
6932 if (!ckWARN_d(WARN_PROTOTYPE))
6936 p = S_strip_spaces(aTHX_ p, &plen);
6937 cvp = S_strip_spaces(aTHX_ cvp, &clen);
6938 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
6939 if (plen == clen && memEQ(cvp, p, plen))
6942 if (flags & SVf_UTF8) {
6943 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
6947 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
6953 msg = sv_newmortal();
6958 gv_efullname3(name = sv_newmortal(), gv, NULL);
6959 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6960 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
6961 else name = (SV *)gv;
6963 sv_setpvs(msg, "Prototype mismatch:");
6965 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6967 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
6968 UTF8fARG(SvUTF8(cv),clen,cvp)
6971 sv_catpvs(msg, ": none");
6972 sv_catpvs(msg, " vs ");
6974 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
6976 sv_catpvs(msg, "none");
6977 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6980 static void const_sv_xsub(pTHX_ CV* cv);
6981 static void const_av_xsub(pTHX_ CV* cv);
6985 =head1 Optree Manipulation Functions
6987 =for apidoc cv_const_sv
6989 If C<cv> is a constant sub eligible for inlining. returns the constant
6990 value returned by the sub. Otherwise, returns NULL.
6992 Constant subs can be created with C<newCONSTSUB> or as described in
6993 L<perlsub/"Constant Functions">.
6998 Perl_cv_const_sv(pTHX_ const CV *const cv)
7001 PERL_UNUSED_CONTEXT;
7004 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7006 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7007 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7012 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7014 PERL_UNUSED_CONTEXT;
7017 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7018 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7021 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7025 Perl_op_const_sv(pTHX_ const OP *o)
7036 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7037 o = cLISTOPo->op_first->op_sibling;
7039 for (; o; o = o->op_next) {
7040 const OPCODE type = o->op_type;
7042 if (sv && o->op_next == o)
7044 if (o->op_next != o) {
7045 if (type == OP_NEXTSTATE
7046 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7047 || type == OP_PUSHMARK)
7049 if (type == OP_DBSTATE)
7052 if (type == OP_LEAVESUB || type == OP_RETURN)
7056 if (type == OP_CONST && cSVOPo->op_sv)
7066 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7067 PADNAME * const name, SV ** const const_svp)
7074 || block->op_type == OP_NULL
7077 if (CvFLAGS(PL_compcv)) {
7078 /* might have had built-in attrs applied */
7079 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7080 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7081 && ckWARN(WARN_MISC))
7083 /* protect against fatal warnings leaking compcv */
7084 SAVEFREESV(PL_compcv);
7085 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7086 SvREFCNT_inc_simple_void_NN(PL_compcv);
7089 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7090 & ~(CVf_LVALUE * pureperl));
7095 /* redundant check for speed: */
7096 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7097 const line_t oldline = CopLINE(PL_curcop);
7100 : sv_2mortal(newSVpvn_utf8(
7101 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7103 if (PL_parser && PL_parser->copline != NOLINE)
7104 /* This ensures that warnings are reported at the first
7105 line of a redefinition, not the last. */
7106 CopLINE_set(PL_curcop, PL_parser->copline);
7107 /* protect against fatal warnings leaking compcv */
7108 SAVEFREESV(PL_compcv);
7109 report_redefined_cv(namesv, cv, const_svp);
7110 SvREFCNT_inc_simple_void_NN(PL_compcv);
7111 CopLINE_set(PL_curcop, oldline);
7114 if (!PL_minus_c) /* keep old one around for madskills */
7117 /* (PL_madskills unset in used file.) */
7124 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7130 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7133 CV *compcv = PL_compcv;
7136 PADOFFSET pax = o->op_targ;
7137 CV *outcv = CvOUTSIDE(PL_compcv);
7140 bool reusable = FALSE;
7142 PERL_ARGS_ASSERT_NEWMYSUB;
7144 /* Find the pad slot for storing the new sub.
7145 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7146 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7147 ing sub. And then we need to dig deeper if this is a lexical from
7149 my sub foo; sub { sub foo { } }
7152 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7153 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7154 pax = PARENT_PAD_INDEX(name);
7155 outcv = CvOUTSIDE(outcv);
7160 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7161 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7162 spot = (CV **)svspot;
7165 assert(proto->op_type == OP_CONST);
7166 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7167 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7172 if (!PL_madskills) {
7179 if (PL_parser && PL_parser->error_count) {
7181 SvREFCNT_dec(PL_compcv);
7186 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7188 svspot = (SV **)(spot = &clonee);
7190 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7194 SvUPGRADE(name, SVt_PVMG);
7195 mg = mg_find(name, PERL_MAGIC_proto);
7196 assert (SvTYPE(*spot) == SVt_PVCV);
7198 hek = CvNAME_HEK(*spot);
7200 CvNAME_HEK_set(*spot, hek =
7203 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7209 cv = (CV *)mg->mg_obj;
7212 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7213 mg = mg_find(name, PERL_MAGIC_proto);
7215 spot = (CV **)(svspot = &mg->mg_obj);
7218 if (!block || !ps || *ps || attrs
7219 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7221 || block->op_type == OP_NULL
7226 const_sv = op_const_sv(block);
7229 const bool exists = CvROOT(cv) || CvXSUB(cv);
7231 /* if the subroutine doesn't exist and wasn't pre-declared
7232 * with a prototype, assume it will be AUTOLOADed,
7233 * skipping the prototype check
7235 if (exists || SvPOK(cv))
7236 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7237 /* already defined? */
7239 if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7242 if (attrs) goto attrs;
7243 /* just a "sub foo;" when &foo is already defined */
7248 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7254 SvREFCNT_inc_simple_void_NN(const_sv);
7255 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7257 assert(!CvROOT(cv) && !CvCONST(cv));
7261 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7262 CvFILE_set_from_cop(cv, PL_curcop);
7263 CvSTASH_set(cv, PL_curstash);
7266 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7267 CvXSUBANY(cv).any_ptr = const_sv;
7268 CvXSUB(cv) = const_sv_xsub;
7274 SvREFCNT_dec(compcv);
7278 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7279 determine whether this sub definition is in the same scope as its
7280 declaration. If this sub definition is inside an inner named pack-
7281 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7282 the package sub. So check PadnameOUTER(name) too.
7284 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7285 assert(!CvWEAKOUTSIDE(compcv));
7286 SvREFCNT_dec(CvOUTSIDE(compcv));
7287 CvWEAKOUTSIDE_on(compcv);
7289 /* XXX else do we have a circular reference? */
7290 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7291 /* transfer PL_compcv to cv */
7294 && block->op_type != OP_NULL
7297 cv_flags_t preserved_flags =
7298 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7299 PADLIST *const temp_padl = CvPADLIST(cv);
7300 CV *const temp_cv = CvOUTSIDE(cv);
7301 const cv_flags_t other_flags =
7302 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7303 OP * const cvstart = CvSTART(cv);
7307 CvFLAGS(compcv) | preserved_flags;
7308 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7309 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7310 CvPADLIST(cv) = CvPADLIST(compcv);
7311 CvOUTSIDE(compcv) = temp_cv;
7312 CvPADLIST(compcv) = temp_padl;
7313 CvSTART(cv) = CvSTART(compcv);
7314 CvSTART(compcv) = cvstart;
7315 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7316 CvFLAGS(compcv) |= other_flags;
7318 if (CvFILE(cv) && CvDYNFILE(cv)) {
7319 Safefree(CvFILE(cv));
7322 /* inner references to compcv must be fixed up ... */
7323 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7324 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7325 ++PL_sub_generation;
7328 /* Might have had built-in attributes applied -- propagate them. */
7329 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7331 /* ... before we throw it away */
7332 SvREFCNT_dec(compcv);
7333 PL_compcv = compcv = cv;
7340 if (!CvNAME_HEK(cv)) {
7343 ? share_hek_hek(hek)
7344 : share_hek(PadnamePV(name)+1,
7345 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7349 if (const_sv) goto clone;
7351 CvFILE_set_from_cop(cv, PL_curcop);
7352 CvSTASH_set(cv, PL_curstash);
7355 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7356 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7363 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7364 the debugger could be able to set a breakpoint in, so signal to
7365 pp_entereval that it should not throw away any saved lines at scope
7368 PL_breakable_sub_gen++;
7369 /* This makes sub {}; work as expected. */
7370 if (block->op_type == OP_STUB) {
7371 OP* const newblock = newSTATEOP(0, NULL, 0);
7373 op_getmad(block,newblock,'B');
7379 CvROOT(cv) = CvLVALUE(cv)
7380 ? newUNOP(OP_LEAVESUBLV, 0,
7381 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7382 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7383 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7384 OpREFCNT_set(CvROOT(cv), 1);
7385 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7386 itself has a refcount. */
7388 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7389 CvSTART(cv) = LINKLIST(CvROOT(cv));
7390 CvROOT(cv)->op_next = 0;
7391 CALL_PEEP(CvSTART(cv));
7392 finalize_optree(CvROOT(cv));
7394 /* now that optimizer has done its work, adjust pad values */
7396 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7400 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7401 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7405 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7406 SV * const tmpstr = sv_newmortal();
7407 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7408 GV_ADDMULTI, SVt_PVHV);
7410 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7413 (long)CopLINE(PL_curcop));
7414 if (HvNAME_HEK(PL_curstash)) {
7415 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7416 sv_catpvs(tmpstr, "::");
7418 else sv_setpvs(tmpstr, "__ANON__::");
7419 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7420 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7421 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7422 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7423 hv = GvHVn(db_postponed);
7424 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7425 CV * const pcv = GvCV(db_postponed);
7431 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7439 assert(CvDEPTH(outcv));
7441 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7442 if (reusable) cv_clone_into(clonee, *spot);
7443 else *spot = cv_clone(clonee);
7444 SvREFCNT_dec_NN(clonee);
7448 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7449 PADOFFSET depth = CvDEPTH(outcv);
7452 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7454 *svspot = SvREFCNT_inc_simple_NN(cv);
7455 SvREFCNT_dec(oldcv);
7461 PL_parser->copline = NOLINE;
7468 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7470 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7474 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7475 OP *block, U32 flags)
7480 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7484 const bool ec = PL_parser && PL_parser->error_count;
7485 /* If the subroutine has no body, no attributes, and no builtin attributes
7486 then it's just a sub declaration, and we may be able to get away with
7487 storing with a placeholder scalar in the symbol table, rather than a
7488 full GV and CV. If anything is present then it will take a full CV to
7490 const I32 gv_fetch_flags
7491 = ec ? GV_NOADD_NOINIT :
7492 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7494 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7496 const bool o_is_gv = flags & 1;
7497 const char * const name =
7498 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7500 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7501 #ifdef PERL_DEBUG_READONLY_OPS
7502 OPSLAB *slab = NULL;
7506 assert(proto->op_type == OP_CONST);
7507 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7508 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7518 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7520 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7521 SV * const sv = sv_newmortal();
7522 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7523 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7524 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7525 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7527 } else if (PL_curstash) {
7528 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7531 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7535 if (!PL_madskills) {
7546 if (name) SvREFCNT_dec(PL_compcv);
7547 else cv = PL_compcv;
7549 if (name && block) {
7550 const char *s = strrchr(name, ':');
7552 if (strEQ(s, "BEGIN")) {
7553 if (PL_in_eval & EVAL_KEEPERR)
7554 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7556 SV * const errsv = ERRSV;
7557 /* force display of errors found but not reported */
7558 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7559 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7566 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7567 maximum a prototype before. */
7568 if (SvTYPE(gv) > SVt_NULL) {
7569 cv_ckproto_len_flags((const CV *)gv,
7570 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7574 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7575 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7578 sv_setiv(MUTABLE_SV(gv), -1);
7580 SvREFCNT_dec(PL_compcv);
7581 cv = PL_compcv = NULL;
7585 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7587 if (!block || !ps || *ps || attrs
7588 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7590 || block->op_type == OP_NULL
7595 const_sv = op_const_sv(block);
7598 const bool exists = CvROOT(cv) || CvXSUB(cv);
7600 /* if the subroutine doesn't exist and wasn't pre-declared
7601 * with a prototype, assume it will be AUTOLOADed,
7602 * skipping the prototype check
7604 if (exists || SvPOK(cv))
7605 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7606 /* already defined (or promised)? */
7607 if (exists || GvASSUMECV(gv)) {
7608 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7611 if (attrs) goto attrs;
7612 /* just a "sub foo;" when &foo is already defined */
7613 SAVEFREESV(PL_compcv);
7619 SvREFCNT_inc_simple_void_NN(const_sv);
7620 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7622 assert(!CvROOT(cv) && !CvCONST(cv));
7624 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7625 CvXSUBANY(cv).any_ptr = const_sv;
7626 CvXSUB(cv) = const_sv_xsub;
7632 cv = newCONSTSUB_flags(
7633 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7640 SvREFCNT_dec(PL_compcv);
7644 if (cv) { /* must reuse cv if autoloaded */
7645 /* transfer PL_compcv to cv */
7648 && block->op_type != OP_NULL
7651 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7652 PADLIST *const temp_av = CvPADLIST(cv);
7653 CV *const temp_cv = CvOUTSIDE(cv);
7654 const cv_flags_t other_flags =
7655 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7656 OP * const cvstart = CvSTART(cv);
7659 assert(!CvCVGV_RC(cv));
7660 assert(CvGV(cv) == gv);
7663 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7664 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7665 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7666 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7667 CvOUTSIDE(PL_compcv) = temp_cv;
7668 CvPADLIST(PL_compcv) = temp_av;
7669 CvSTART(cv) = CvSTART(PL_compcv);
7670 CvSTART(PL_compcv) = cvstart;
7671 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7672 CvFLAGS(PL_compcv) |= other_flags;
7674 if (CvFILE(cv) && CvDYNFILE(cv)) {
7675 Safefree(CvFILE(cv));
7677 CvFILE_set_from_cop(cv, PL_curcop);
7678 CvSTASH_set(cv, PL_curstash);
7680 /* inner references to PL_compcv must be fixed up ... */
7681 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7682 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7683 ++PL_sub_generation;
7686 /* Might have had built-in attributes applied -- propagate them. */
7687 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7689 /* ... before we throw it away */
7690 SvREFCNT_dec(PL_compcv);
7698 if (HvENAME_HEK(GvSTASH(gv)))
7699 /* sub Foo::bar { (shift)+1 } */
7700 gv_method_changed(gv);
7705 CvFILE_set_from_cop(cv, PL_curcop);
7706 CvSTASH_set(cv, PL_curstash);
7710 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7711 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7718 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7719 the debugger could be able to set a breakpoint in, so signal to
7720 pp_entereval that it should not throw away any saved lines at scope
7723 PL_breakable_sub_gen++;
7724 /* This makes sub {}; work as expected. */
7725 if (block->op_type == OP_STUB) {
7726 OP* const newblock = newSTATEOP(0, NULL, 0);
7728 op_getmad(block,newblock,'B');
7734 CvROOT(cv) = CvLVALUE(cv)
7735 ? newUNOP(OP_LEAVESUBLV, 0,
7736 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7737 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7738 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7739 OpREFCNT_set(CvROOT(cv), 1);
7740 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7741 itself has a refcount. */
7743 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7744 #ifdef PERL_DEBUG_READONLY_OPS
7745 slab = (OPSLAB *)CvSTART(cv);
7747 CvSTART(cv) = LINKLIST(CvROOT(cv));
7748 CvROOT(cv)->op_next = 0;
7749 CALL_PEEP(CvSTART(cv));
7750 finalize_optree(CvROOT(cv));
7752 /* now that optimizer has done its work, adjust pad values */
7754 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7758 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7759 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7760 if (!name) SAVEFREESV(cv);
7761 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7762 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7765 if (block && has_name) {
7766 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7767 SV * const tmpstr = sv_newmortal();
7768 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7769 GV_ADDMULTI, SVt_PVHV);
7771 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7774 (long)CopLINE(PL_curcop));
7775 gv_efullname3(tmpstr, gv, NULL);
7776 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7777 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7778 hv = GvHVn(db_postponed);
7779 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7780 CV * const pcv = GvCV(db_postponed);
7786 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7791 if (name && ! (PL_parser && PL_parser->error_count))
7792 process_special_blocks(floor, name, gv, cv);
7797 PL_parser->copline = NOLINE;
7799 #ifdef PERL_DEBUG_READONLY_OPS
7800 /* Watch out for BEGIN blocks */
7801 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7807 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7811 const char *const colon = strrchr(fullname,':');
7812 const char *const name = colon ? colon + 1 : fullname;
7814 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7817 if (strEQ(name, "BEGIN")) {
7818 const I32 oldscope = PL_scopestack_ix;
7819 if (floor) LEAVE_SCOPE(floor);
7821 SAVECOPFILE(&PL_compiling);
7822 SAVECOPLINE(&PL_compiling);
7823 SAVEVPTR(PL_curcop);
7825 DEBUG_x( dump_sub(gv) );
7826 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7827 GvCV_set(gv,0); /* cv has been hijacked */
7828 call_list(oldscope, PL_beginav);
7836 if strEQ(name, "END") {
7837 DEBUG_x( dump_sub(gv) );
7838 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7841 } else if (*name == 'U') {
7842 if (strEQ(name, "UNITCHECK")) {
7843 /* It's never too late to run a unitcheck block */
7844 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7848 } else if (*name == 'C') {
7849 if (strEQ(name, "CHECK")) {
7851 /* diag_listed_as: Too late to run %s block */
7852 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7853 "Too late to run CHECK block");
7854 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7858 } else if (*name == 'I') {
7859 if (strEQ(name, "INIT")) {
7861 /* diag_listed_as: Too late to run %s block */
7862 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7863 "Too late to run INIT block");
7864 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7870 DEBUG_x( dump_sub(gv) );
7871 GvCV_set(gv,0); /* cv has been hijacked */
7876 =for apidoc newCONSTSUB
7878 See L</newCONSTSUB_flags>.
7884 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7886 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7890 =for apidoc newCONSTSUB_flags
7892 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7893 eligible for inlining at compile-time.
7895 Currently, the only useful value for C<flags> is SVf_UTF8.
7897 The newly created subroutine takes ownership of a reference to the passed in
7900 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7901 which won't be called if used as a destructor, but will suppress the overhead
7902 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7909 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7914 const char *const file = CopFILE(PL_curcop);
7918 if (IN_PERL_RUNTIME) {
7919 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7920 * an op shared between threads. Use a non-shared COP for our
7922 SAVEVPTR(PL_curcop);
7923 SAVECOMPILEWARNINGS();
7924 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7925 PL_curcop = &PL_compiling;
7927 SAVECOPLINE(PL_curcop);
7928 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7931 PL_hints &= ~HINT_BLOCK_SCOPE;
7934 SAVEGENERICSV(PL_curstash);
7935 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7938 /* Protect sv against leakage caused by fatal warnings. */
7939 if (sv) SAVEFREESV(sv);
7941 /* file becomes the CvFILE. For an XS, it's usually static storage,
7942 and so doesn't get free()d. (It's expected to be from the C pre-
7943 processor __FILE__ directive). But we need a dynamically allocated one,
7944 and we need it to get freed. */
7945 cv = newXS_len_flags(name, len,
7946 sv && SvTYPE(sv) == SVt_PVAV
7949 file ? file : "", "",
7950 &sv, XS_DYNAMIC_FILENAME | flags);
7951 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
7960 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7961 const char *const filename, const char *const proto,
7964 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7965 return newXS_len_flags(
7966 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7971 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7972 XSUBADDR_t subaddr, const char *const filename,
7973 const char *const proto, SV **const_svp,
7978 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7981 GV * const gv = gv_fetchpvn(
7982 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7983 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7984 sizeof("__ANON__::__ANON__") - 1,
7985 GV_ADDMULTI | flags, SVt_PVCV);
7988 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7990 if ((cv = (name ? GvCV(gv) : NULL))) {
7992 /* just a cached method */
7996 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7997 /* already defined (or promised) */
7998 /* Redundant check that allows us to avoid creating an SV
7999 most of the time: */
8000 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8001 report_redefined_cv(newSVpvn_flags(
8002 name,len,(flags&SVf_UTF8)|SVs_TEMP
8006 SvREFCNT_dec_NN(cv);
8011 if (cv) /* must reuse cv if autoloaded */
8014 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8018 if (HvENAME_HEK(GvSTASH(gv)))
8019 gv_method_changed(gv); /* newXS */
8025 (void)gv_fetchfile(filename);
8026 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8027 an external constant string */
8028 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8030 CvXSUB(cv) = subaddr;
8033 process_special_blocks(0, name, gv, cv);
8036 if (flags & XS_DYNAMIC_FILENAME) {
8037 CvFILE(cv) = savepv(filename);
8040 sv_setpv(MUTABLE_SV(cv), proto);
8045 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8047 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8049 PERL_ARGS_ASSERT_NEWSTUB;
8053 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8054 gv_method_changed(gv);
8056 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8061 CvFILE_set_from_cop(cv, PL_curcop);
8062 CvSTASH_set(cv, PL_curstash);
8068 =for apidoc U||newXS
8070 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8071 static storage, as it is used directly as CvFILE(), without a copy being made.
8077 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8079 PERL_ARGS_ASSERT_NEWXS;
8080 return newXS_len_flags(
8081 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8090 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8095 OP* pegop = newOP(OP_NULL, 0);
8100 if (PL_parser && PL_parser->error_count) {
8106 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8107 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8110 if ((cv = GvFORM(gv))) {
8111 if (ckWARN(WARN_REDEFINE)) {
8112 const line_t oldline = CopLINE(PL_curcop);
8113 if (PL_parser && PL_parser->copline != NOLINE)
8114 CopLINE_set(PL_curcop, PL_parser->copline);
8116 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8117 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8119 /* diag_listed_as: Format %s redefined */
8120 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8121 "Format STDOUT redefined");
8123 CopLINE_set(PL_curcop, oldline);
8128 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8130 CvFILE_set_from_cop(cv, PL_curcop);
8133 pad_tidy(padtidy_FORMAT);
8134 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8135 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8136 OpREFCNT_set(CvROOT(cv), 1);
8137 CvSTART(cv) = LINKLIST(CvROOT(cv));
8138 CvROOT(cv)->op_next = 0;
8139 CALL_PEEP(CvSTART(cv));
8140 finalize_optree(CvROOT(cv));
8145 op_getmad(o,pegop,'n');
8146 op_getmad_weak(block, pegop, 'b');
8151 PL_parser->copline = NOLINE;
8159 Perl_newANONLIST(pTHX_ OP *o)
8161 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8165 Perl_newANONHASH(pTHX_ OP *o)
8167 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8171 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8173 return newANONATTRSUB(floor, proto, NULL, block);
8177 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8179 return newUNOP(OP_REFGEN, 0,
8180 newSVOP(OP_ANONCODE, 0,
8181 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8185 Perl_oopsAV(pTHX_ OP *o)
8189 PERL_ARGS_ASSERT_OOPSAV;
8191 switch (o->op_type) {
8194 o->op_type = OP_PADAV;
8195 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8196 return ref(o, OP_RV2AV);
8200 o->op_type = OP_RV2AV;
8201 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8206 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8213 Perl_oopsHV(pTHX_ OP *o)
8217 PERL_ARGS_ASSERT_OOPSHV;
8219 switch (o->op_type) {
8222 o->op_type = OP_PADHV;
8223 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8224 return ref(o, OP_RV2HV);
8228 o->op_type = OP_RV2HV;
8229 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8234 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8241 Perl_newAVREF(pTHX_ OP *o)
8245 PERL_ARGS_ASSERT_NEWAVREF;
8247 if (o->op_type == OP_PADANY) {
8248 o->op_type = OP_PADAV;
8249 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8252 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8253 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8254 "Using an array as a reference is deprecated");
8256 return newUNOP(OP_RV2AV, 0, scalar(o));
8260 Perl_newGVREF(pTHX_ I32 type, OP *o)
8262 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8263 return newUNOP(OP_NULL, 0, o);
8264 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8268 Perl_newHVREF(pTHX_ OP *o)
8272 PERL_ARGS_ASSERT_NEWHVREF;
8274 if (o->op_type == OP_PADANY) {
8275 o->op_type = OP_PADHV;
8276 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8279 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8280 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8281 "Using a hash as a reference is deprecated");
8283 return newUNOP(OP_RV2HV, 0, scalar(o));
8287 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8289 if (o->op_type == OP_PADANY) {
8291 o->op_type = OP_PADCV;
8292 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8294 return newUNOP(OP_RV2CV, flags, scalar(o));
8298 Perl_newSVREF(pTHX_ OP *o)
8302 PERL_ARGS_ASSERT_NEWSVREF;
8304 if (o->op_type == OP_PADANY) {
8305 o->op_type = OP_PADSV;
8306 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8309 return newUNOP(OP_RV2SV, 0, scalar(o));
8312 /* Check routines. See the comments at the top of this file for details
8313 * on when these are called */
8316 Perl_ck_anoncode(pTHX_ OP *o)
8318 PERL_ARGS_ASSERT_CK_ANONCODE;
8320 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8322 cSVOPo->op_sv = NULL;
8327 Perl_ck_bitop(pTHX_ OP *o)
8331 PERL_ARGS_ASSERT_CK_BITOP;
8333 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8334 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8335 && (o->op_type == OP_BIT_OR
8336 || o->op_type == OP_BIT_AND
8337 || o->op_type == OP_BIT_XOR))
8339 const OP * const left = cBINOPo->op_first;
8340 const OP * const right = left->op_sibling;
8341 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8342 (left->op_flags & OPf_PARENS) == 0) ||
8343 (OP_IS_NUMCOMPARE(right->op_type) &&
8344 (right->op_flags & OPf_PARENS) == 0))
8345 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8346 "Possible precedence problem on bitwise %c operator",
8347 o->op_type == OP_BIT_OR ? '|'
8348 : o->op_type == OP_BIT_AND ? '&' : '^'
8354 PERL_STATIC_INLINE bool
8355 is_dollar_bracket(pTHX_ const OP * const o)
8358 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8359 && (kid = cUNOPx(o)->op_first)
8360 && kid->op_type == OP_GV
8361 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8365 Perl_ck_cmp(pTHX_ OP *o)
8367 PERL_ARGS_ASSERT_CK_CMP;
8368 if (ckWARN(WARN_SYNTAX)) {
8369 const OP *kid = cUNOPo->op_first;
8372 is_dollar_bracket(aTHX_ kid)
8373 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8375 || ( kid->op_type == OP_CONST
8376 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8378 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8379 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8385 Perl_ck_concat(pTHX_ OP *o)
8387 const OP * const kid = cUNOPo->op_first;
8389 PERL_ARGS_ASSERT_CK_CONCAT;
8390 PERL_UNUSED_CONTEXT;
8392 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8393 !(kUNOP->op_first->op_flags & OPf_MOD))
8394 o->op_flags |= OPf_STACKED;
8399 Perl_ck_spair(pTHX_ OP *o)
8403 PERL_ARGS_ASSERT_CK_SPAIR;
8405 if (o->op_flags & OPf_KIDS) {
8408 const OPCODE type = o->op_type;
8409 o = modkids(ck_fun(o), type);
8410 kid = cUNOPo->op_first;
8411 newop = kUNOP->op_first->op_sibling;
8413 const OPCODE type = newop->op_type;
8414 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8415 type == OP_PADAV || type == OP_PADHV ||
8416 type == OP_RV2AV || type == OP_RV2HV)
8420 op_getmad(kUNOP->op_first,newop,'K');
8422 op_free(kUNOP->op_first);
8424 kUNOP->op_first = newop;
8426 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8427 * and OP_CHOMP into OP_SCHOMP */
8428 o->op_ppaddr = PL_ppaddr[++o->op_type];
8433 Perl_ck_delete(pTHX_ OP *o)
8435 PERL_ARGS_ASSERT_CK_DELETE;
8439 if (o->op_flags & OPf_KIDS) {
8440 OP * const kid = cUNOPo->op_first;
8441 switch (kid->op_type) {
8443 o->op_flags |= OPf_SPECIAL;
8446 o->op_private |= OPpSLICE;
8449 o->op_flags |= OPf_SPECIAL;
8454 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8455 " use array slice");
8457 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8460 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8461 "element or slice");
8463 if (kid->op_private & OPpLVAL_INTRO)
8464 o->op_private |= OPpLVAL_INTRO;
8471 Perl_ck_die(pTHX_ OP *o)
8473 PERL_ARGS_ASSERT_CK_DIE;
8476 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8482 Perl_ck_eof(pTHX_ OP *o)
8486 PERL_ARGS_ASSERT_CK_EOF;
8488 if (o->op_flags & OPf_KIDS) {
8490 if (cLISTOPo->op_first->op_type == OP_STUB) {
8492 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8494 op_getmad(o,newop,'O');
8501 kid = cLISTOPo->op_first;
8502 if (kid->op_type == OP_RV2GV)
8503 kid->op_private |= OPpALLOW_FAKE;
8509 Perl_ck_eval(pTHX_ OP *o)
8513 PERL_ARGS_ASSERT_CK_EVAL;
8515 PL_hints |= HINT_BLOCK_SCOPE;
8516 if (o->op_flags & OPf_KIDS) {
8517 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8520 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8526 cUNOPo->op_first = 0;
8531 NewOp(1101, enter, 1, LOGOP);
8532 enter->op_type = OP_ENTERTRY;
8533 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8534 enter->op_private = 0;
8536 /* establish postfix order */
8537 enter->op_next = (OP*)enter;
8539 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8540 o->op_type = OP_LEAVETRY;
8541 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8542 enter->op_other = o;
8543 op_getmad(oldo,o,'O');
8552 const U8 priv = o->op_private;
8558 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8559 op_getmad(oldo,o,'O');
8561 o->op_targ = (PADOFFSET)PL_hints;
8562 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8563 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8564 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8565 /* Store a copy of %^H that pp_entereval can pick up. */
8566 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8567 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8568 cUNOPo->op_first->op_sibling = hhop;
8569 o->op_private |= OPpEVAL_HAS_HH;
8571 if (!(o->op_private & OPpEVAL_BYTES)
8572 && FEATURE_UNIEVAL_IS_ENABLED)
8573 o->op_private |= OPpEVAL_UNICODE;
8578 Perl_ck_exit(pTHX_ OP *o)
8580 PERL_ARGS_ASSERT_CK_EXIT;
8583 HV * const table = GvHV(PL_hintgv);
8585 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8586 if (svp && *svp && SvTRUE(*svp))
8587 o->op_private |= OPpEXIT_VMSISH;
8589 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8595 Perl_ck_exec(pTHX_ OP *o)
8597 PERL_ARGS_ASSERT_CK_EXEC;
8599 if (o->op_flags & OPf_STACKED) {
8602 kid = cUNOPo->op_first->op_sibling;
8603 if (kid->op_type == OP_RV2GV)
8612 Perl_ck_exists(pTHX_ OP *o)
8616 PERL_ARGS_ASSERT_CK_EXISTS;
8619 if (o->op_flags & OPf_KIDS) {
8620 OP * const kid = cUNOPo->op_first;
8621 if (kid->op_type == OP_ENTERSUB) {
8622 (void) ref(kid, o->op_type);
8623 if (kid->op_type != OP_RV2CV
8624 && !(PL_parser && PL_parser->error_count))
8626 "exists argument is not a subroutine name");
8627 o->op_private |= OPpEXISTS_SUB;
8629 else if (kid->op_type == OP_AELEM)
8630 o->op_flags |= OPf_SPECIAL;
8631 else if (kid->op_type != OP_HELEM)
8632 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8633 "element or a subroutine");
8640 Perl_ck_rvconst(pTHX_ OP *o)
8643 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8645 PERL_ARGS_ASSERT_CK_RVCONST;
8647 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8648 if (o->op_type == OP_RV2CV)
8649 o->op_private &= ~1;
8651 if (kid->op_type == OP_CONST) {
8654 SV * const kidsv = kid->op_sv;
8656 /* Is it a constant from cv_const_sv()? */
8657 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8658 SV * const rsv = SvRV(kidsv);
8659 const svtype type = SvTYPE(rsv);
8660 const char *badtype = NULL;
8662 switch (o->op_type) {
8664 if (type > SVt_PVMG)
8665 badtype = "a SCALAR";
8668 if (type != SVt_PVAV)
8669 badtype = "an ARRAY";
8672 if (type != SVt_PVHV)
8676 if (type != SVt_PVCV)
8681 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8684 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8685 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8686 const char *badthing;
8687 switch (o->op_type) {
8689 badthing = "a SCALAR";
8692 badthing = "an ARRAY";
8695 badthing = "a HASH";
8703 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8704 SVfARG(kidsv), badthing);
8707 * This is a little tricky. We only want to add the symbol if we
8708 * didn't add it in the lexer. Otherwise we get duplicate strict
8709 * warnings. But if we didn't add it in the lexer, we must at
8710 * least pretend like we wanted to add it even if it existed before,
8711 * or we get possible typo warnings. OPpCONST_ENTERED says
8712 * whether the lexer already added THIS instance of this symbol.
8714 iscv = (o->op_type == OP_RV2CV) * 2;
8716 gv = gv_fetchsv(kidsv,
8717 iscv | !(kid->op_private & OPpCONST_ENTERED),
8720 : o->op_type == OP_RV2SV
8722 : o->op_type == OP_RV2AV
8724 : o->op_type == OP_RV2HV
8727 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8729 kid->op_type = OP_GV;
8730 SvREFCNT_dec(kid->op_sv);
8732 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8733 assert (sizeof(PADOP) <= sizeof(SVOP));
8734 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8735 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8737 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8739 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8741 kid->op_private = 0;
8742 kid->op_ppaddr = PL_ppaddr[OP_GV];
8743 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8751 Perl_ck_ftst(pTHX_ OP *o)
8754 const I32 type = o->op_type;
8756 PERL_ARGS_ASSERT_CK_FTST;
8758 if (o->op_flags & OPf_REF) {
8761 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8762 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8763 const OPCODE kidtype = kid->op_type;
8765 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8766 && !kid->op_folded) {
8767 OP * const newop = newGVOP(type, OPf_REF,
8768 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8770 op_getmad(o,newop,'O');
8776 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8777 o->op_private |= OPpFT_ACCESS;
8778 if (PL_check[kidtype] == Perl_ck_ftst
8779 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8780 o->op_private |= OPpFT_STACKED;
8781 kid->op_private |= OPpFT_STACKING;
8782 if (kidtype == OP_FTTTY && (
8783 !(kid->op_private & OPpFT_STACKED)
8784 || kid->op_private & OPpFT_AFTER_t
8786 o->op_private |= OPpFT_AFTER_t;
8795 if (type == OP_FTTTY)
8796 o = newGVOP(type, OPf_REF, PL_stdingv);
8798 o = newUNOP(type, 0, newDEFSVOP());
8799 op_getmad(oldo,o,'O');
8805 Perl_ck_fun(pTHX_ OP *o)
8808 const int type = o->op_type;
8809 I32 oa = PL_opargs[type] >> OASHIFT;
8811 PERL_ARGS_ASSERT_CK_FUN;
8813 if (o->op_flags & OPf_STACKED) {
8814 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8817 return no_fh_allowed(o);
8820 if (o->op_flags & OPf_KIDS) {
8821 OP **tokid = &cLISTOPo->op_first;
8822 OP *kid = cLISTOPo->op_first;
8825 bool seen_optional = FALSE;
8827 if (kid->op_type == OP_PUSHMARK ||
8828 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8830 tokid = &kid->op_sibling;
8831 kid = kid->op_sibling;
8833 if (kid && kid->op_type == OP_COREARGS) {
8834 bool optional = FALSE;
8837 if (oa & OA_OPTIONAL) optional = TRUE;
8840 if (optional) o->op_private |= numargs;
8845 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8846 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8847 *tokid = kid = newDEFSVOP();
8848 seen_optional = TRUE;
8853 sibl = kid->op_sibling;
8855 if (!sibl && kid->op_type == OP_STUB) {
8862 /* list seen where single (scalar) arg expected? */
8863 if (numargs == 1 && !(oa >> 4)
8864 && kid->op_type == OP_LIST && type != OP_SCALAR)
8866 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8879 if ((type == OP_PUSH || type == OP_UNSHIFT)
8880 && !kid->op_sibling)
8881 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8882 "Useless use of %s with no values",
8885 if (kid->op_type == OP_CONST &&
8886 (kid->op_private & OPpCONST_BARE))
8888 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8889 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8890 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8891 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8892 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8894 op_getmad(kid,newop,'K');
8899 kid->op_sibling = sibl;
8902 else if (kid->op_type == OP_CONST
8903 && ( !SvROK(cSVOPx_sv(kid))
8904 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8906 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8907 /* Defer checks to run-time if we have a scalar arg */
8908 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8909 op_lvalue(kid, type);
8913 if (kid->op_type == OP_CONST &&
8914 (kid->op_private & OPpCONST_BARE))
8916 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8917 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8918 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8919 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8920 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8922 op_getmad(kid,newop,'K');
8927 kid->op_sibling = sibl;
8930 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8931 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8932 op_lvalue(kid, type);
8936 OP * const newop = newUNOP(OP_NULL, 0, kid);
8937 kid->op_sibling = 0;
8938 newop->op_next = newop;
8940 kid->op_sibling = sibl;
8945 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8946 if (kid->op_type == OP_CONST &&
8947 (kid->op_private & OPpCONST_BARE))
8949 OP * const newop = newGVOP(OP_GV, 0,
8950 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8951 if (!(o->op_private & 1) && /* if not unop */
8952 kid == cLISTOPo->op_last)
8953 cLISTOPo->op_last = newop;
8955 op_getmad(kid,newop,'K');
8961 else if (kid->op_type == OP_READLINE) {
8962 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8963 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8966 I32 flags = OPf_SPECIAL;
8970 /* is this op a FH constructor? */
8971 if (is_handle_constructor(o,numargs)) {
8972 const char *name = NULL;
8975 bool want_dollar = TRUE;
8978 /* Set a flag to tell rv2gv to vivify
8979 * need to "prove" flag does not mean something
8980 * else already - NI-S 1999/05/07
8983 if (kid->op_type == OP_PADSV) {
8985 = PAD_COMPNAME_SV(kid->op_targ);
8986 name = SvPV_const(namesv, len);
8987 name_utf8 = SvUTF8(namesv);
8989 else if (kid->op_type == OP_RV2SV
8990 && kUNOP->op_first->op_type == OP_GV)
8992 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8994 len = GvNAMELEN(gv);
8995 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8997 else if (kid->op_type == OP_AELEM
8998 || kid->op_type == OP_HELEM)
9001 OP *op = ((BINOP*)kid)->op_first;
9005 const char * const a =
9006 kid->op_type == OP_AELEM ?
9008 if (((op->op_type == OP_RV2AV) ||
9009 (op->op_type == OP_RV2HV)) &&
9010 (firstop = ((UNOP*)op)->op_first) &&
9011 (firstop->op_type == OP_GV)) {
9012 /* packagevar $a[] or $h{} */
9013 GV * const gv = cGVOPx_gv(firstop);
9021 else if (op->op_type == OP_PADAV
9022 || op->op_type == OP_PADHV) {
9023 /* lexicalvar $a[] or $h{} */
9024 const char * const padname =
9025 PAD_COMPNAME_PV(op->op_targ);
9034 name = SvPV_const(tmpstr, len);
9035 name_utf8 = SvUTF8(tmpstr);
9040 name = "__ANONIO__";
9042 want_dollar = FALSE;
9044 op_lvalue(kid, type);
9048 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9049 namesv = PAD_SVl(targ);
9050 if (want_dollar && *name != '$')
9051 sv_setpvs(namesv, "$");
9053 sv_setpvs(namesv, "");
9054 sv_catpvn(namesv, name, len);
9055 if ( name_utf8 ) SvUTF8_on(namesv);
9058 kid->op_sibling = 0;
9059 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
9060 kid->op_targ = targ;
9061 kid->op_private |= priv;
9063 kid->op_sibling = sibl;
9069 if ((type == OP_UNDEF || type == OP_POS)
9070 && numargs == 1 && !(oa >> 4)
9071 && kid->op_type == OP_LIST)
9072 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9073 op_lvalue(scalar(kid), type);
9077 tokid = &kid->op_sibling;
9078 kid = kid->op_sibling;
9081 if (kid && kid->op_type != OP_STUB)
9082 return too_many_arguments_pv(o,OP_DESC(o), 0);
9083 o->op_private |= numargs;
9085 /* FIXME - should the numargs move as for the PERL_MAD case? */
9086 o->op_private |= numargs;
9088 return too_many_arguments_pv(o,OP_DESC(o), 0);
9092 else if (PL_opargs[type] & OA_DEFGV) {
9094 OP *newop = newUNOP(type, 0, newDEFSVOP());
9095 op_getmad(o,newop,'O');
9098 /* Ordering of these two is important to keep f_map.t passing. */
9100 return newUNOP(type, 0, newDEFSVOP());
9105 while (oa & OA_OPTIONAL)
9107 if (oa && oa != OA_LIST)
9108 return too_few_arguments_pv(o,OP_DESC(o), 0);
9114 Perl_ck_glob(pTHX_ OP *o)
9118 const bool core = o->op_flags & OPf_SPECIAL;
9120 PERL_ARGS_ASSERT_CK_GLOB;
9123 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9124 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9126 if (core) gv = NULL;
9127 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
9128 && GvCVu(gv) && GvIMPORTED_CV(gv)))
9130 GV * const * const gvp =
9131 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
9132 gv = gvp ? *gvp : NULL;
9135 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9138 * \ null - const(wildcard)
9143 * \ mark - glob - rv2cv
9144 * | \ gv(CORE::GLOBAL::glob)
9146 * \ null - const(wildcard)
9148 o->op_flags |= OPf_SPECIAL;
9149 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9150 o = newLISTOP(OP_LIST, 0, o, NULL);
9151 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
9152 op_append_elem(OP_LIST, o,
9153 scalar(newUNOP(OP_RV2CV, 0,
9154 newGVOP(OP_GV, 0, gv)))));
9155 o = newUNOP(OP_NULL, 0, o);
9156 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9159 else o->op_flags &= ~OPf_SPECIAL;
9160 #if !defined(PERL_EXTERNAL_GLOB)
9163 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9164 newSVpvs("File::Glob"), NULL, NULL, NULL);
9167 #endif /* !PERL_EXTERNAL_GLOB */
9168 gv = (GV *)newSV(0);
9169 gv_init(gv, 0, "", 0, 0);
9171 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9172 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9178 Perl_ck_grep(pTHX_ OP *o)
9183 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9186 PERL_ARGS_ASSERT_CK_GREP;
9188 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9189 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9191 if (o->op_flags & OPf_STACKED) {
9192 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9193 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9194 return no_fh_allowed(o);
9195 o->op_flags &= ~OPf_STACKED;
9197 kid = cLISTOPo->op_first->op_sibling;
9198 if (type == OP_MAPWHILE)
9203 if (PL_parser && PL_parser->error_count)
9205 kid = cLISTOPo->op_first->op_sibling;
9206 if (kid->op_type != OP_NULL)
9207 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9208 kid = kUNOP->op_first;
9210 NewOp(1101, gwop, 1, LOGOP);
9211 gwop->op_type = type;
9212 gwop->op_ppaddr = PL_ppaddr[type];
9214 gwop->op_flags |= OPf_KIDS;
9215 gwop->op_other = LINKLIST(kid);
9216 kid->op_next = (OP*)gwop;
9217 offset = pad_findmy_pvs("$_", 0);
9218 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9219 o->op_private = gwop->op_private = 0;
9220 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9223 o->op_private = gwop->op_private = OPpGREP_LEX;
9224 gwop->op_targ = o->op_targ = offset;
9227 kid = cLISTOPo->op_first->op_sibling;
9228 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9229 op_lvalue(kid, OP_GREPSTART);
9235 Perl_ck_index(pTHX_ OP *o)
9237 PERL_ARGS_ASSERT_CK_INDEX;
9239 if (o->op_flags & OPf_KIDS) {
9240 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9242 kid = kid->op_sibling; /* get past "big" */
9243 if (kid && kid->op_type == OP_CONST) {
9244 const bool save_taint = TAINT_get;
9245 SV *sv = kSVOP->op_sv;
9246 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9248 sv_copypv(sv, kSVOP->op_sv);
9249 SvREFCNT_dec_NN(kSVOP->op_sv);
9252 if (SvOK(sv)) fbm_compile(sv, 0);
9253 TAINT_set(save_taint);
9254 #ifdef NO_TAINT_SUPPORT
9255 PERL_UNUSED_VAR(save_taint);
9263 Perl_ck_lfun(pTHX_ OP *o)
9265 const OPCODE type = o->op_type;
9267 PERL_ARGS_ASSERT_CK_LFUN;
9269 return modkids(ck_fun(o), type);
9273 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9275 PERL_ARGS_ASSERT_CK_DEFINED;
9277 if ((o->op_flags & OPf_KIDS)) {
9278 switch (cUNOPo->op_first->op_type) {
9281 case OP_AASSIGN: /* Is this a good idea? */
9282 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9283 "defined(@array) is deprecated");
9284 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9285 "\t(Maybe you should just omit the defined()?)\n");
9289 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9290 "defined(%%hash) is deprecated");
9291 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9292 "\t(Maybe you should just omit the defined()?)\n");
9303 Perl_ck_readline(pTHX_ OP *o)
9305 PERL_ARGS_ASSERT_CK_READLINE;
9307 if (o->op_flags & OPf_KIDS) {
9308 OP *kid = cLISTOPo->op_first;
9309 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9313 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9315 op_getmad(o,newop,'O');
9325 Perl_ck_rfun(pTHX_ OP *o)
9327 const OPCODE type = o->op_type;
9329 PERL_ARGS_ASSERT_CK_RFUN;
9331 return refkids(ck_fun(o), type);
9335 Perl_ck_listiob(pTHX_ OP *o)
9339 PERL_ARGS_ASSERT_CK_LISTIOB;
9341 kid = cLISTOPo->op_first;
9344 kid = cLISTOPo->op_first;
9346 if (kid->op_type == OP_PUSHMARK)
9347 kid = kid->op_sibling;
9348 if (kid && o->op_flags & OPf_STACKED)
9349 kid = kid->op_sibling;
9350 else if (kid && !kid->op_sibling) { /* print HANDLE; */
9351 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9352 && !kid->op_folded) {
9353 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9354 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9355 cLISTOPo->op_first->op_sibling = kid;
9356 cLISTOPo->op_last = kid;
9357 kid = kid->op_sibling;
9362 op_append_elem(o->op_type, o, newDEFSVOP());
9364 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9369 Perl_ck_smartmatch(pTHX_ OP *o)
9372 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9373 if (0 == (o->op_flags & OPf_SPECIAL)) {
9374 OP *first = cBINOPo->op_first;
9375 OP *second = first->op_sibling;
9377 /* Implicitly take a reference to an array or hash */
9378 first->op_sibling = NULL;
9379 first = cBINOPo->op_first = ref_array_or_hash(first);
9380 second = first->op_sibling = ref_array_or_hash(second);
9382 /* Implicitly take a reference to a regular expression */
9383 if (first->op_type == OP_MATCH) {
9384 first->op_type = OP_QR;
9385 first->op_ppaddr = PL_ppaddr[OP_QR];
9387 if (second->op_type == OP_MATCH) {
9388 second->op_type = OP_QR;
9389 second->op_ppaddr = PL_ppaddr[OP_QR];
9398 Perl_ck_sassign(pTHX_ OP *o)
9401 OP * const kid = cLISTOPo->op_first;
9403 PERL_ARGS_ASSERT_CK_SASSIGN;
9405 /* has a disposable target? */
9406 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9407 && !(kid->op_flags & OPf_STACKED)
9408 /* Cannot steal the second time! */
9409 && !(kid->op_private & OPpTARGET_MY)
9410 /* Keep the full thing for madskills */
9414 OP * const kkid = kid->op_sibling;
9416 /* Can just relocate the target. */
9417 if (kkid && kkid->op_type == OP_PADSV
9418 && !(kkid->op_private & OPpLVAL_INTRO))
9420 kid->op_targ = kkid->op_targ;
9422 /* Now we do not need PADSV and SASSIGN. */
9423 kid->op_sibling = o->op_sibling; /* NULL */
9424 cLISTOPo->op_first = NULL;
9427 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9431 if (kid->op_sibling) {
9432 OP *kkid = kid->op_sibling;
9433 /* For state variable assignment, kkid is a list op whose op_last
9435 if ((kkid->op_type == OP_PADSV ||
9436 (kkid->op_type == OP_LIST &&
9437 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9440 && (kkid->op_private & OPpLVAL_INTRO)
9441 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9442 const PADOFFSET target = kkid->op_targ;
9443 OP *const other = newOP(OP_PADSV,
9445 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9446 OP *const first = newOP(OP_NULL, 0);
9447 OP *const nullop = newCONDOP(0, first, o, other);
9448 OP *const condop = first->op_next;
9449 /* hijacking PADSTALE for uninitialized state variables */
9450 SvPADSTALE_on(PAD_SVl(target));
9452 condop->op_type = OP_ONCE;
9453 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9454 condop->op_targ = target;
9455 other->op_targ = target;
9457 /* Because we change the type of the op here, we will skip the
9458 assignment binop->op_last = binop->op_first->op_sibling; at the
9459 end of Perl_newBINOP(). So need to do it here. */
9460 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9469 Perl_ck_match(pTHX_ OP *o)
9473 PERL_ARGS_ASSERT_CK_MATCH;
9475 if (o->op_type != OP_QR && PL_compcv) {
9476 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9477 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9478 o->op_targ = offset;
9479 o->op_private |= OPpTARGET_MY;
9482 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9483 o->op_private |= OPpRUNTIME;
9488 Perl_ck_method(pTHX_ OP *o)
9490 OP * const kid = cUNOPo->op_first;
9492 PERL_ARGS_ASSERT_CK_METHOD;
9494 if (kid->op_type == OP_CONST) {
9495 SV* sv = kSVOP->op_sv;
9496 const char * const method = SvPVX_const(sv);
9497 if (!(strchr(method, ':') || strchr(method, '\''))) {
9499 if (!SvIsCOW_shared_hash(sv)) {
9500 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9503 kSVOP->op_sv = NULL;
9505 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9507 op_getmad(o,cmop,'O');
9518 Perl_ck_null(pTHX_ OP *o)
9520 PERL_ARGS_ASSERT_CK_NULL;
9521 PERL_UNUSED_CONTEXT;
9526 Perl_ck_open(pTHX_ OP *o)
9529 HV * const table = GvHV(PL_hintgv);
9531 PERL_ARGS_ASSERT_CK_OPEN;
9534 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9537 const char *d = SvPV_const(*svp, len);
9538 const I32 mode = mode_from_discipline(d, len);
9539 if (mode & O_BINARY)
9540 o->op_private |= OPpOPEN_IN_RAW;
9541 else if (mode & O_TEXT)
9542 o->op_private |= OPpOPEN_IN_CRLF;
9545 svp = hv_fetchs(table, "open_OUT", FALSE);
9548 const char *d = SvPV_const(*svp, len);
9549 const I32 mode = mode_from_discipline(d, len);
9550 if (mode & O_BINARY)
9551 o->op_private |= OPpOPEN_OUT_RAW;
9552 else if (mode & O_TEXT)
9553 o->op_private |= OPpOPEN_OUT_CRLF;
9556 if (o->op_type == OP_BACKTICK) {
9557 if (!(o->op_flags & OPf_KIDS)) {
9558 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9560 op_getmad(o,newop,'O');
9569 /* In case of three-arg dup open remove strictness
9570 * from the last arg if it is a bareword. */
9571 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9572 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9576 if ((last->op_type == OP_CONST) && /* The bareword. */
9577 (last->op_private & OPpCONST_BARE) &&
9578 (last->op_private & OPpCONST_STRICT) &&
9579 (oa = first->op_sibling) && /* The fh. */
9580 (oa = oa->op_sibling) && /* The mode. */
9581 (oa->op_type == OP_CONST) &&
9582 SvPOK(((SVOP*)oa)->op_sv) &&
9583 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9584 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9585 (last == oa->op_sibling)) /* The bareword. */
9586 last->op_private &= ~OPpCONST_STRICT;
9592 Perl_ck_repeat(pTHX_ OP *o)
9594 PERL_ARGS_ASSERT_CK_REPEAT;
9596 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9597 o->op_private |= OPpREPEAT_DOLIST;
9598 cBINOPo->op_first = force_list(cBINOPo->op_first);
9606 Perl_ck_require(pTHX_ OP *o)
9611 PERL_ARGS_ASSERT_CK_REQUIRE;
9613 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9614 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9616 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9617 SV * const sv = kid->op_sv;
9618 U32 was_readonly = SvREADONLY(sv);
9626 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9631 for (; s < end; s++) {
9632 if (*s == ':' && s[1] == ':') {
9634 Move(s+2, s+1, end - s - 1, char);
9639 sv_catpvs(sv, ".pm");
9640 SvFLAGS(sv) |= was_readonly;
9644 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9645 /* handle override, if any */
9646 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9647 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9648 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9649 gv = gvp ? *gvp : NULL;
9653 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9655 if (o->op_flags & OPf_KIDS) {
9656 kid = cUNOPo->op_first;
9657 cUNOPo->op_first = NULL;
9665 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9666 op_append_elem(OP_LIST, kid,
9667 scalar(newUNOP(OP_RV2CV, 0,
9670 op_getmad(o,newop,'O');
9674 return scalar(ck_fun(o));
9678 Perl_ck_return(pTHX_ OP *o)
9683 PERL_ARGS_ASSERT_CK_RETURN;
9685 kid = cLISTOPo->op_first->op_sibling;
9686 if (CvLVALUE(PL_compcv)) {
9687 for (; kid; kid = kid->op_sibling)
9688 op_lvalue(kid, OP_LEAVESUBLV);
9695 Perl_ck_select(pTHX_ OP *o)
9700 PERL_ARGS_ASSERT_CK_SELECT;
9702 if (o->op_flags & OPf_KIDS) {
9703 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9704 if (kid && kid->op_sibling) {
9705 o->op_type = OP_SSELECT;
9706 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9708 return fold_constants(op_integerize(op_std_init(o)));
9712 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9713 if (kid && kid->op_type == OP_RV2GV)
9714 kid->op_private &= ~HINT_STRICT_REFS;
9719 Perl_ck_shift(pTHX_ OP *o)
9722 const I32 type = o->op_type;
9724 PERL_ARGS_ASSERT_CK_SHIFT;
9726 if (!(o->op_flags & OPf_KIDS)) {
9729 if (!CvUNIQUE(PL_compcv)) {
9730 o->op_flags |= OPf_SPECIAL;
9734 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9737 OP * const oldo = o;
9738 o = newUNOP(type, 0, scalar(argop));
9739 op_getmad(oldo,o,'O');
9744 return newUNOP(type, 0, scalar(argop));
9747 return scalar(ck_fun(o));
9751 Perl_ck_sort(pTHX_ OP *o)
9757 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9760 PERL_ARGS_ASSERT_CK_SORT;
9763 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9765 const I32 sorthints = (I32)SvIV(*svp);
9766 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9767 o->op_private |= OPpSORT_QSORT;
9768 if ((sorthints & HINT_SORT_STABLE) != 0)
9769 o->op_private |= OPpSORT_STABLE;
9773 if (o->op_flags & OPf_STACKED)
9775 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9776 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9777 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9779 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9781 if (kid->op_type == OP_LEAVE)
9782 op_null(kid); /* wipe out leave */
9783 /* Prevent execution from escaping out of the sort block. */
9786 /* provide scalar context for comparison function/block */
9787 kid = scalar(firstkid);
9789 o->op_flags |= OPf_SPECIAL;
9792 firstkid = firstkid->op_sibling;
9795 for (kid = firstkid; kid; kid = kid->op_sibling) {
9796 /* provide list context for arguments */
9799 op_lvalue(kid, OP_GREPSTART);
9806 S_simplify_sort(pTHX_ OP *o)
9809 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9816 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9818 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9819 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9820 kid = kUNOP->op_first; /* get past null */
9821 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9822 && kid->op_type != OP_LEAVE)
9824 kid = kLISTOP->op_last; /* get past scope */
9825 switch(kid->op_type) {
9829 if (!have_scopeop) goto padkids;
9834 k = kid; /* remember this node*/
9835 if (kBINOP->op_first->op_type != OP_RV2SV
9836 || kBINOP->op_last ->op_type != OP_RV2SV)
9839 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9840 then used in a comparison. This catches most, but not
9841 all cases. For instance, it catches
9842 sort { my($a); $a <=> $b }
9844 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9845 (although why you'd do that is anyone's guess).
9849 if (!ckWARN(WARN_SYNTAX)) return;
9850 kid = kBINOP->op_first;
9852 if (kid->op_type == OP_PADSV) {
9853 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9854 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9855 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9856 /* diag_listed_as: "my %s" used in sort comparison */
9857 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9858 "\"%s %s\" used in sort comparison",
9859 SvPAD_STATE(name) ? "state" : "my",
9862 } while ((kid = kid->op_sibling));
9865 kid = kBINOP->op_first; /* get past cmp */
9866 if (kUNOP->op_first->op_type != OP_GV)
9868 kid = kUNOP->op_first; /* get past rv2sv */
9870 if (GvSTASH(gv) != PL_curstash)
9872 gvname = GvNAME(gv);
9873 if (*gvname == 'a' && gvname[1] == '\0')
9875 else if (*gvname == 'b' && gvname[1] == '\0')
9880 kid = k; /* back to cmp */
9881 /* already checked above that it is rv2sv */
9882 kid = kBINOP->op_last; /* down to 2nd arg */
9883 if (kUNOP->op_first->op_type != OP_GV)
9885 kid = kUNOP->op_first; /* get past rv2sv */
9887 if (GvSTASH(gv) != PL_curstash)
9889 gvname = GvNAME(gv);
9891 ? !(*gvname == 'a' && gvname[1] == '\0')
9892 : !(*gvname == 'b' && gvname[1] == '\0'))
9894 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9896 o->op_private |= OPpSORT_DESCEND;
9897 if (k->op_type == OP_NCMP)
9898 o->op_private |= OPpSORT_NUMERIC;
9899 if (k->op_type == OP_I_NCMP)
9900 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9901 kid = cLISTOPo->op_first->op_sibling;
9902 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9904 op_getmad(kid,o,'S'); /* then delete it */
9906 op_free(kid); /* then delete it */
9911 Perl_ck_split(pTHX_ OP *o)
9916 PERL_ARGS_ASSERT_CK_SPLIT;
9918 if (o->op_flags & OPf_STACKED)
9919 return no_fh_allowed(o);
9921 kid = cLISTOPo->op_first;
9922 if (kid->op_type != OP_NULL)
9923 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9924 kid = kid->op_sibling;
9925 op_free(cLISTOPo->op_first);
9927 cLISTOPo->op_first = kid;
9929 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9930 cLISTOPo->op_last = kid; /* There was only one element previously */
9933 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9934 OP * const sibl = kid->op_sibling;
9935 kid->op_sibling = 0;
9936 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
9937 if (cLISTOPo->op_first == cLISTOPo->op_last)
9938 cLISTOPo->op_last = kid;
9939 cLISTOPo->op_first = kid;
9940 kid->op_sibling = sibl;
9943 kid->op_type = OP_PUSHRE;
9944 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9946 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9947 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9948 "Use of /g modifier is meaningless in split");
9951 if (!kid->op_sibling)
9952 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9954 kid = kid->op_sibling;
9957 if (!kid->op_sibling)
9959 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9960 o->op_private |= OPpSPLIT_IMPLIM;
9962 assert(kid->op_sibling);
9964 kid = kid->op_sibling;
9967 if (kid->op_sibling)
9968 return too_many_arguments_pv(o,OP_DESC(o), 0);
9974 Perl_ck_join(pTHX_ OP *o)
9976 const OP * const kid = cLISTOPo->op_first->op_sibling;
9978 PERL_ARGS_ASSERT_CK_JOIN;
9980 if (kid && kid->op_type == OP_MATCH) {
9981 if (ckWARN(WARN_SYNTAX)) {
9982 const REGEXP *re = PM_GETRE(kPMOP);
9984 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9985 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9986 : newSVpvs_flags( "STRING", SVs_TEMP );
9987 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9988 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9989 SVfARG(msg), SVfARG(msg));
9996 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9998 Examines an op, which is expected to identify a subroutine at runtime,
9999 and attempts to determine at compile time which subroutine it identifies.
10000 This is normally used during Perl compilation to determine whether
10001 a prototype can be applied to a function call. I<cvop> is the op
10002 being considered, normally an C<rv2cv> op. A pointer to the identified
10003 subroutine is returned, if it could be determined statically, and a null
10004 pointer is returned if it was not possible to determine statically.
10006 Currently, the subroutine can be identified statically if the RV that the
10007 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10008 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10009 suitable if the constant value must be an RV pointing to a CV. Details of
10010 this process may change in future versions of Perl. If the C<rv2cv> op
10011 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10012 the subroutine statically: this flag is used to suppress compile-time
10013 magic on a subroutine call, forcing it to use default runtime behaviour.
10015 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10016 of a GV reference is modified. If a GV was examined and its CV slot was
10017 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10018 If the op is not optimised away, and the CV slot is later populated with
10019 a subroutine having a prototype, that flag eventually triggers the warning
10020 "called too early to check prototype".
10022 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10023 of returning a pointer to the subroutine it returns a pointer to the
10024 GV giving the most appropriate name for the subroutine in this context.
10025 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10026 (C<CvANON>) subroutine that is referenced through a GV it will be the
10027 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10028 A null pointer is returned as usual if there is no statically-determinable
10034 /* shared by toke.c:yylex */
10036 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10038 PADNAME *name = PAD_COMPNAME(off);
10039 CV *compcv = PL_compcv;
10040 while (PadnameOUTER(name)) {
10041 assert(PARENT_PAD_INDEX(name));
10042 compcv = CvOUTSIDE(PL_compcv);
10043 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10044 [off = PARENT_PAD_INDEX(name)];
10046 assert(!PadnameIsOUR(name));
10047 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10048 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10050 assert(mg->mg_obj);
10051 return (CV *)mg->mg_obj;
10053 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10057 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10062 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10063 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10064 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10065 if (cvop->op_type != OP_RV2CV)
10067 if (cvop->op_private & OPpENTERSUB_AMPER)
10069 if (!(cvop->op_flags & OPf_KIDS))
10071 rvop = cUNOPx(cvop)->op_first;
10072 switch (rvop->op_type) {
10074 gv = cGVOPx_gv(rvop);
10077 if (flags & RV2CVOPCV_MARK_EARLY)
10078 rvop->op_private |= OPpEARLY_CV;
10083 SV *rv = cSVOPx_sv(rvop);
10086 cv = (CV*)SvRV(rv);
10090 cv = find_lexical_cv(rvop->op_targ);
10097 if (SvTYPE((SV*)cv) != SVt_PVCV)
10099 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10100 if (!CvANON(cv) || !gv)
10109 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10111 Performs the default fixup of the arguments part of an C<entersub>
10112 op tree. This consists of applying list context to each of the
10113 argument ops. This is the standard treatment used on a call marked
10114 with C<&>, or a method call, or a call through a subroutine reference,
10115 or any other call where the callee can't be identified at compile time,
10116 or a call where the callee has no prototype.
10122 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10125 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10126 aop = cUNOPx(entersubop)->op_first;
10127 if (!aop->op_sibling)
10128 aop = cUNOPx(aop)->op_first;
10129 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10130 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10132 op_lvalue(aop, OP_ENTERSUB);
10139 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10141 Performs the fixup of the arguments part of an C<entersub> op tree
10142 based on a subroutine prototype. This makes various modifications to
10143 the argument ops, from applying context up to inserting C<refgen> ops,
10144 and checking the number and syntactic types of arguments, as directed by
10145 the prototype. This is the standard treatment used on a subroutine call,
10146 not marked with C<&>, where the callee can be identified at compile time
10147 and has a prototype.
10149 I<protosv> supplies the subroutine prototype to be applied to the call.
10150 It may be a normal defined scalar, of which the string value will be used.
10151 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10152 that has been cast to C<SV*>) which has a prototype. The prototype
10153 supplied, in whichever form, does not need to match the actual callee
10154 referenced by the op tree.
10156 If the argument ops disagree with the prototype, for example by having
10157 an unacceptable number of arguments, a valid op tree is returned anyway.
10158 The error is reflected in the parser state, normally resulting in a single
10159 exception at the top level of parsing which covers all the compilation
10160 errors that occurred. In the error message, the callee is referred to
10161 by the name defined by the I<namegv> parameter.
10167 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10170 const char *proto, *proto_end;
10171 OP *aop, *prev, *cvop;
10174 I32 contextclass = 0;
10175 const char *e = NULL;
10176 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10177 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10178 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10179 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10180 if (SvTYPE(protosv) == SVt_PVCV)
10181 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10182 else proto = SvPV(protosv, proto_len);
10183 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10184 proto_end = proto + proto_len;
10185 aop = cUNOPx(entersubop)->op_first;
10186 if (!aop->op_sibling)
10187 aop = cUNOPx(aop)->op_first;
10189 aop = aop->op_sibling;
10190 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10191 while (aop != cvop) {
10193 if (PL_madskills && aop->op_type == OP_STUB) {
10194 aop = aop->op_sibling;
10197 if (PL_madskills && aop->op_type == OP_NULL)
10198 o3 = ((UNOP*)aop)->op_first;
10202 if (proto >= proto_end)
10203 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10211 /* _ must be at the end */
10212 if (proto[1] && !strchr(";@%", proto[1]))
10227 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10229 arg == 1 ? "block or sub {}" : "sub {}",
10233 /* '*' allows any scalar type, including bareword */
10236 if (o3->op_type == OP_RV2GV)
10237 goto wrapref; /* autoconvert GLOB -> GLOBref */
10238 else if (o3->op_type == OP_CONST)
10239 o3->op_private &= ~OPpCONST_STRICT;
10240 else if (o3->op_type == OP_ENTERSUB) {
10241 /* accidental subroutine, revert to bareword */
10242 OP *gvop = ((UNOP*)o3)->op_first;
10243 if (gvop && gvop->op_type == OP_NULL) {
10244 gvop = ((UNOP*)gvop)->op_first;
10246 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10249 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10250 (gvop = ((UNOP*)gvop)->op_first) &&
10251 gvop->op_type == OP_GV)
10253 GV * const gv = cGVOPx_gv(gvop);
10254 OP * const sibling = aop->op_sibling;
10255 SV * const n = newSVpvs("");
10257 OP * const oldaop = aop;
10261 gv_fullname4(n, gv, "", FALSE);
10262 aop = newSVOP(OP_CONST, 0, n);
10263 op_getmad(oldaop,aop,'O');
10264 prev->op_sibling = aop;
10265 aop->op_sibling = sibling;
10275 if (o3->op_type == OP_RV2AV ||
10276 o3->op_type == OP_PADAV ||
10277 o3->op_type == OP_RV2HV ||
10278 o3->op_type == OP_PADHV
10284 case '[': case ']':
10291 switch (*proto++) {
10293 if (contextclass++ == 0) {
10294 e = strchr(proto, ']');
10295 if (!e || e == proto)
10303 if (contextclass) {
10304 const char *p = proto;
10305 const char *const end = proto;
10307 while (*--p != '[')
10308 /* \[$] accepts any scalar lvalue */
10310 && Perl_op_lvalue_flags(aTHX_
10312 OP_READ, /* not entersub */
10315 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10316 (int)(end - p), p),
10322 if (o3->op_type == OP_RV2GV)
10325 bad_type_gv(arg, "symbol", namegv, 0, o3);
10328 if (o3->op_type == OP_ENTERSUB)
10331 bad_type_gv(arg, "subroutine entry", namegv, 0,
10335 if (o3->op_type == OP_RV2SV ||
10336 o3->op_type == OP_PADSV ||
10337 o3->op_type == OP_HELEM ||
10338 o3->op_type == OP_AELEM)
10340 if (!contextclass) {
10341 /* \$ accepts any scalar lvalue */
10342 if (Perl_op_lvalue_flags(aTHX_
10344 OP_READ, /* not entersub */
10347 bad_type_gv(arg, "scalar", namegv, 0, o3);
10351 if (o3->op_type == OP_RV2AV ||
10352 o3->op_type == OP_PADAV)
10355 bad_type_gv(arg, "array", namegv, 0, o3);
10358 if (o3->op_type == OP_RV2HV ||
10359 o3->op_type == OP_PADHV)
10362 bad_type_gv(arg, "hash", namegv, 0, o3);
10366 OP* const kid = aop;
10367 OP* const sib = kid->op_sibling;
10368 kid->op_sibling = 0;
10369 aop = newUNOP(OP_REFGEN, 0, kid);
10370 aop->op_sibling = sib;
10371 prev->op_sibling = aop;
10373 if (contextclass && e) {
10378 default: goto oops;
10388 SV* const tmpsv = sv_newmortal();
10389 gv_efullname3(tmpsv, namegv, NULL);
10390 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10391 SVfARG(tmpsv), SVfARG(protosv));
10395 op_lvalue(aop, OP_ENTERSUB);
10397 aop = aop->op_sibling;
10399 if (aop == cvop && *proto == '_') {
10400 /* generate an access to $_ */
10401 aop = newDEFSVOP();
10402 aop->op_sibling = prev->op_sibling;
10403 prev->op_sibling = aop; /* instead of cvop */
10405 if (!optional && proto_end > proto &&
10406 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10407 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10412 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10414 Performs the fixup of the arguments part of an C<entersub> op tree either
10415 based on a subroutine prototype or using default list-context processing.
10416 This is the standard treatment used on a subroutine call, not marked
10417 with C<&>, where the callee can be identified at compile time.
10419 I<protosv> supplies the subroutine prototype to be applied to the call,
10420 or indicates that there is no prototype. It may be a normal scalar,
10421 in which case if it is defined then the string value will be used
10422 as a prototype, and if it is undefined then there is no prototype.
10423 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10424 that has been cast to C<SV*>), of which the prototype will be used if it
10425 has one. The prototype (or lack thereof) supplied, in whichever form,
10426 does not need to match the actual callee referenced by the op tree.
10428 If the argument ops disagree with the prototype, for example by having
10429 an unacceptable number of arguments, a valid op tree is returned anyway.
10430 The error is reflected in the parser state, normally resulting in a single
10431 exception at the top level of parsing which covers all the compilation
10432 errors that occurred. In the error message, the callee is referred to
10433 by the name defined by the I<namegv> parameter.
10439 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10440 GV *namegv, SV *protosv)
10442 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10443 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10444 return ck_entersub_args_proto(entersubop, namegv, protosv);
10446 return ck_entersub_args_list(entersubop);
10450 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10452 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10453 OP *aop = cUNOPx(entersubop)->op_first;
10455 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10459 if (!aop->op_sibling)
10460 aop = cUNOPx(aop)->op_first;
10461 aop = aop->op_sibling;
10462 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10463 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10464 aop = aop->op_sibling;
10467 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10469 op_free(entersubop);
10470 switch(GvNAME(namegv)[2]) {
10471 case 'F': return newSVOP(OP_CONST, 0,
10472 newSVpv(CopFILE(PL_curcop),0));
10473 case 'L': return newSVOP(
10475 Perl_newSVpvf(aTHX_
10476 "%"IVdf, (IV)CopLINE(PL_curcop)
10479 case 'P': return newSVOP(OP_CONST, 0,
10481 ? newSVhek(HvNAME_HEK(PL_curstash))
10492 bool seenarg = FALSE;
10494 if (!aop->op_sibling)
10495 aop = cUNOPx(aop)->op_first;
10498 aop = aop->op_sibling;
10499 prev->op_sibling = NULL;
10502 prev=cvop, cvop = cvop->op_sibling)
10504 if (PL_madskills && cvop->op_sibling
10505 && cvop->op_type != OP_STUB) seenarg = TRUE
10508 prev->op_sibling = NULL;
10509 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10511 if (aop == cvop) aop = NULL;
10512 op_free(entersubop);
10514 if (opnum == OP_ENTEREVAL
10515 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10516 flags |= OPpEVAL_BYTES <<8;
10518 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10520 case OA_BASEOP_OR_UNOP:
10521 case OA_FILESTATOP:
10522 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10526 if (!PL_madskills || seenarg)
10528 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10531 return opnum == OP_RUNCV
10532 ? newPVOP(OP_RUNCV,0,NULL)
10535 return convert(opnum,0,aop);
10543 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10545 Retrieves the function that will be used to fix up a call to I<cv>.
10546 Specifically, the function is applied to an C<entersub> op tree for a
10547 subroutine call, not marked with C<&>, where the callee can be identified
10548 at compile time as I<cv>.
10550 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10551 argument for it is returned in I<*ckobj_p>. The function is intended
10552 to be called in this manner:
10554 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10556 In this call, I<entersubop> is a pointer to the C<entersub> op,
10557 which may be replaced by the check function, and I<namegv> is a GV
10558 supplying the name that should be used by the check function to refer
10559 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10560 It is permitted to apply the check function in non-standard situations,
10561 such as to a call to a different subroutine or to a method call.
10563 By default, the function is
10564 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10565 and the SV parameter is I<cv> itself. This implements standard
10566 prototype processing. It can be changed, for a particular subroutine,
10567 by L</cv_set_call_checker>.
10573 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10576 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10577 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10579 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10580 *ckobj_p = callmg->mg_obj;
10582 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10583 *ckobj_p = (SV*)cv;
10588 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10590 Sets the function that will be used to fix up a call to I<cv>.
10591 Specifically, the function is applied to an C<entersub> op tree for a
10592 subroutine call, not marked with C<&>, where the callee can be identified
10593 at compile time as I<cv>.
10595 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10596 for it is supplied in I<ckobj>. The function is intended to be called
10599 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10601 In this call, I<entersubop> is a pointer to the C<entersub> op,
10602 which may be replaced by the check function, and I<namegv> is a GV
10603 supplying the name that should be used by the check function to refer
10604 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10605 It is permitted to apply the check function in non-standard situations,
10606 such as to a call to a different subroutine or to a method call.
10608 The current setting for a particular CV can be retrieved by
10609 L</cv_get_call_checker>.
10615 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10617 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10618 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10619 if (SvMAGICAL((SV*)cv))
10620 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10623 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10624 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10625 if (callmg->mg_flags & MGf_REFCOUNTED) {
10626 SvREFCNT_dec(callmg->mg_obj);
10627 callmg->mg_flags &= ~MGf_REFCOUNTED;
10629 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10630 callmg->mg_obj = ckobj;
10631 if (ckobj != (SV*)cv) {
10632 SvREFCNT_inc_simple_void_NN(ckobj);
10633 callmg->mg_flags |= MGf_REFCOUNTED;
10635 callmg->mg_flags |= MGf_COPY;
10640 Perl_ck_subr(pTHX_ OP *o)
10646 PERL_ARGS_ASSERT_CK_SUBR;
10648 aop = cUNOPx(o)->op_first;
10649 if (!aop->op_sibling)
10650 aop = cUNOPx(aop)->op_first;
10651 aop = aop->op_sibling;
10652 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10653 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10654 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10656 o->op_private &= ~1;
10657 o->op_private |= OPpENTERSUB_HASTARG;
10658 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10659 if (PERLDB_SUB && PL_curstash != PL_debstash)
10660 o->op_private |= OPpENTERSUB_DB;
10661 if (cvop->op_type == OP_RV2CV) {
10662 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10664 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10665 if (aop->op_type == OP_CONST)
10666 aop->op_private &= ~OPpCONST_STRICT;
10667 else if (aop->op_type == OP_LIST) {
10668 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10669 if (sib && sib->op_type == OP_CONST)
10670 sib->op_private &= ~OPpCONST_STRICT;
10675 return ck_entersub_args_list(o);
10677 Perl_call_checker ckfun;
10679 cv_get_call_checker(cv, &ckfun, &ckobj);
10680 if (!namegv) { /* expletive! */
10681 /* XXX The call checker API is public. And it guarantees that
10682 a GV will be provided with the right name. So we have
10683 to create a GV. But it is still not correct, as its
10684 stringification will include the package. What we
10685 really need is a new call checker API that accepts a
10686 GV or string (or GV or CV). */
10687 HEK * const hek = CvNAME_HEK(cv);
10688 /* After a syntax error in a lexical sub, the cv that
10689 rv2cv_op_cv returns may be a nameless stub. */
10690 if (!hek) return ck_entersub_args_list(o);;
10691 namegv = (GV *)sv_newmortal();
10692 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10693 SVf_UTF8 * !!HEK_UTF8(hek));
10695 return ckfun(aTHX_ o, namegv, ckobj);
10700 Perl_ck_svconst(pTHX_ OP *o)
10702 SV * const sv = cSVOPo->op_sv;
10703 PERL_ARGS_ASSERT_CK_SVCONST;
10704 PERL_UNUSED_CONTEXT;
10705 #ifdef PERL_OLD_COPY_ON_WRITE
10706 if (SvIsCOW(sv)) sv_force_normal(sv);
10707 #elif defined(PERL_NEW_COPY_ON_WRITE)
10708 /* Since the read-only flag may be used to protect a string buffer, we
10709 cannot do copy-on-write with existing read-only scalars that are not
10710 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10711 that constant, mark the constant as COWable here, if it is not
10712 already read-only. */
10713 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10723 Perl_ck_trunc(pTHX_ OP *o)
10725 PERL_ARGS_ASSERT_CK_TRUNC;
10727 if (o->op_flags & OPf_KIDS) {
10728 SVOP *kid = (SVOP*)cUNOPo->op_first;
10730 if (kid->op_type == OP_NULL)
10731 kid = (SVOP*)kid->op_sibling;
10732 if (kid && kid->op_type == OP_CONST &&
10733 (kid->op_private & OPpCONST_BARE) &&
10736 o->op_flags |= OPf_SPECIAL;
10737 kid->op_private &= ~OPpCONST_STRICT;
10744 Perl_ck_substr(pTHX_ OP *o)
10746 PERL_ARGS_ASSERT_CK_SUBSTR;
10749 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10750 OP *kid = cLISTOPo->op_first;
10752 if (kid->op_type == OP_NULL)
10753 kid = kid->op_sibling;
10755 kid->op_flags |= OPf_MOD;
10762 Perl_ck_tell(pTHX_ OP *o)
10764 PERL_ARGS_ASSERT_CK_TELL;
10766 if (o->op_flags & OPf_KIDS) {
10767 OP *kid = cLISTOPo->op_first;
10768 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10769 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10775 Perl_ck_each(pTHX_ OP *o)
10778 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10779 const unsigned orig_type = o->op_type;
10780 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10781 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10782 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10783 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10785 PERL_ARGS_ASSERT_CK_EACH;
10788 switch (kid->op_type) {
10794 CHANGE_TYPE(o, array_type);
10797 if (kid->op_private == OPpCONST_BARE
10798 || !SvROK(cSVOPx_sv(kid))
10799 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10800 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10802 /* we let ck_fun handle it */
10805 CHANGE_TYPE(o, ref_type);
10809 /* if treating as a reference, defer additional checks to runtime */
10810 return o->op_type == ref_type ? o : ck_fun(o);
10814 Perl_ck_length(pTHX_ OP *o)
10816 PERL_ARGS_ASSERT_CK_LENGTH;
10820 if (ckWARN(WARN_SYNTAX)) {
10821 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10825 const bool hash = kid->op_type == OP_PADHV
10826 || kid->op_type == OP_RV2HV;
10827 switch (kid->op_type) {
10832 name = S_op_varname(aTHX_ kid);
10838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10839 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10841 name, hash ? "keys " : "", name
10844 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10845 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10846 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10848 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10850 "length() used on @array (did you mean \"scalar(@array)\"?)");
10857 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10858 and modify the optree to make them work inplace */
10861 S_inplace_aassign(pTHX_ OP *o) {
10863 OP *modop, *modop_pushmark;
10865 OP *oleft, *oleft_pushmark;
10867 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10869 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10871 assert(cUNOPo->op_first->op_type == OP_NULL);
10872 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10873 assert(modop_pushmark->op_type == OP_PUSHMARK);
10874 modop = modop_pushmark->op_sibling;
10876 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10879 /* no other operation except sort/reverse */
10880 if (modop->op_sibling)
10883 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10884 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10886 if (modop->op_flags & OPf_STACKED) {
10887 /* skip sort subroutine/block */
10888 assert(oright->op_type == OP_NULL);
10889 oright = oright->op_sibling;
10892 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10893 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10894 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10895 oleft = oleft_pushmark->op_sibling;
10897 /* Check the lhs is an array */
10899 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10900 || oleft->op_sibling
10901 || (oleft->op_private & OPpLVAL_INTRO)
10905 /* Only one thing on the rhs */
10906 if (oright->op_sibling)
10909 /* check the array is the same on both sides */
10910 if (oleft->op_type == OP_RV2AV) {
10911 if (oright->op_type != OP_RV2AV
10912 || !cUNOPx(oright)->op_first
10913 || cUNOPx(oright)->op_first->op_type != OP_GV
10914 || cUNOPx(oleft )->op_first->op_type != OP_GV
10915 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10916 cGVOPx_gv(cUNOPx(oright)->op_first)
10920 else if (oright->op_type != OP_PADAV
10921 || oright->op_targ != oleft->op_targ
10925 /* This actually is an inplace assignment */
10927 modop->op_private |= OPpSORT_INPLACE;
10929 /* transfer MODishness etc from LHS arg to RHS arg */
10930 oright->op_flags = oleft->op_flags;
10932 /* remove the aassign op and the lhs */
10934 op_null(oleft_pushmark);
10935 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10936 op_null(cUNOPx(oleft)->op_first);
10940 #define MAX_DEFERRED 4
10944 if (defer_ix == (MAX_DEFERRED-1)) { \
10945 CALL_RPEEP(defer_queue[defer_base]); \
10946 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10949 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10952 /* A peephole optimizer. We visit the ops in the order they're to execute.
10953 * See the comments at the top of this file for more details about when
10954 * peep() is called */
10957 Perl_rpeep(pTHX_ OP *o)
10961 OP* oldoldop = NULL;
10962 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10963 int defer_base = 0;
10966 if (!o || o->op_opt)
10970 SAVEVPTR(PL_curcop);
10971 for (;; o = o->op_next) {
10972 if (o && o->op_opt)
10975 while (defer_ix >= 0)
10976 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10980 /* By default, this op has now been optimised. A couple of cases below
10981 clear this again. */
10984 switch (o->op_type) {
10986 PL_curcop = ((COP*)o); /* for warnings */
10989 PL_curcop = ((COP*)o); /* for warnings */
10991 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10992 to carry two labels. For now, take the easier option, and skip
10993 this optimisation if the first NEXTSTATE has a label. */
10994 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10995 OP *nextop = o->op_next;
10996 while (nextop && nextop->op_type == OP_NULL)
10997 nextop = nextop->op_next;
10999 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11000 COP *firstcop = (COP *)o;
11001 COP *secondcop = (COP *)nextop;
11002 /* We want the COP pointed to by o (and anything else) to
11003 become the next COP down the line. */
11004 cop_free(firstcop);
11006 firstcop->op_next = secondcop->op_next;
11008 /* Now steal all its pointers, and duplicate the other
11010 firstcop->cop_line = secondcop->cop_line;
11011 #ifdef USE_ITHREADS
11012 firstcop->cop_stashoff = secondcop->cop_stashoff;
11013 firstcop->cop_file = secondcop->cop_file;
11015 firstcop->cop_stash = secondcop->cop_stash;
11016 firstcop->cop_filegv = secondcop->cop_filegv;
11018 firstcop->cop_hints = secondcop->cop_hints;
11019 firstcop->cop_seq = secondcop->cop_seq;
11020 firstcop->cop_warnings = secondcop->cop_warnings;
11021 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11023 #ifdef USE_ITHREADS
11024 secondcop->cop_stashoff = 0;
11025 secondcop->cop_file = NULL;
11027 secondcop->cop_stash = NULL;
11028 secondcop->cop_filegv = NULL;
11030 secondcop->cop_warnings = NULL;
11031 secondcop->cop_hints_hash = NULL;
11033 /* If we use op_null(), and hence leave an ex-COP, some
11034 warnings are misreported. For example, the compile-time
11035 error in 'use strict; no strict refs;' */
11036 secondcop->op_type = OP_NULL;
11037 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11043 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11044 if (o->op_next->op_private & OPpTARGET_MY) {
11045 if (o->op_flags & OPf_STACKED) /* chained concats */
11046 break; /* ignore_optimization */
11048 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11049 o->op_targ = o->op_next->op_targ;
11050 o->op_next->op_targ = 0;
11051 o->op_private |= OPpTARGET_MY;
11054 op_null(o->op_next);
11058 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11059 break; /* Scalar stub must produce undef. List stub is noop */
11063 if (o->op_targ == OP_NEXTSTATE
11064 || o->op_targ == OP_DBSTATE)
11066 PL_curcop = ((COP*)o);
11068 /* XXX: We avoid setting op_seq here to prevent later calls
11069 to rpeep() from mistakenly concluding that optimisation
11070 has already occurred. This doesn't fix the real problem,
11071 though (See 20010220.007). AMS 20010719 */
11072 /* op_seq functionality is now replaced by op_opt */
11079 if (oldop && o->op_next) {
11080 oldop->op_next = o->op_next;
11088 /* Convert a series of PAD ops for my vars plus support into a
11089 * single padrange op. Basically
11091 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11093 * becomes, depending on circumstances, one of
11095 * padrange ----------------------------------> (list) -> rest
11096 * padrange --------------------------------------------> rest
11098 * where all the pad indexes are sequential and of the same type
11100 * We convert the pushmark into a padrange op, then skip
11101 * any other pad ops, and possibly some trailing ops.
11102 * Note that we don't null() the skipped ops, to make it
11103 * easier for Deparse to undo this optimisation (and none of
11104 * the skipped ops are holding any resourses). It also makes
11105 * it easier for find_uninit_var(), as it can just ignore
11106 * padrange, and examine the original pad ops.
11110 OP *followop = NULL; /* the op that will follow the padrange op */
11113 PADOFFSET base = 0; /* init only to stop compiler whining */
11114 U8 gimme = 0; /* init only to stop compiler whining */
11115 bool defav = 0; /* seen (...) = @_ */
11116 bool reuse = 0; /* reuse an existing padrange op */
11118 /* look for a pushmark -> gv[_] -> rv2av */
11124 if ( p->op_type == OP_GV
11125 && (gv = cGVOPx_gv(p))
11126 && GvNAMELEN_get(gv) == 1
11127 && *GvNAME_get(gv) == '_'
11128 && GvSTASH(gv) == PL_defstash
11129 && (rv2av = p->op_next)
11130 && rv2av->op_type == OP_RV2AV
11131 && !(rv2av->op_flags & OPf_REF)
11132 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11133 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11134 && o->op_sibling == rv2av /* these two for Deparse */
11135 && cUNOPx(rv2av)->op_first == p
11137 q = rv2av->op_next;
11138 if (q->op_type == OP_NULL)
11140 if (q->op_type == OP_PUSHMARK) {
11147 /* To allow Deparse to pessimise this, it needs to be able
11148 * to restore the pushmark's original op_next, which it
11149 * will assume to be the same as op_sibling. */
11150 if (o->op_next != o->op_sibling)
11155 /* scan for PAD ops */
11157 for (p = p->op_next; p; p = p->op_next) {
11158 if (p->op_type == OP_NULL)
11161 if (( p->op_type != OP_PADSV
11162 && p->op_type != OP_PADAV
11163 && p->op_type != OP_PADHV
11165 /* any private flag other than INTRO? e.g. STATE */
11166 || (p->op_private & ~OPpLVAL_INTRO)
11170 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11172 if ( p->op_type == OP_PADAV
11174 && p->op_next->op_type == OP_CONST
11175 && p->op_next->op_next
11176 && p->op_next->op_next->op_type == OP_AELEM
11180 /* for 1st padop, note what type it is and the range
11181 * start; for the others, check that it's the same type
11182 * and that the targs are contiguous */
11184 intro = (p->op_private & OPpLVAL_INTRO);
11186 gimme = (p->op_flags & OPf_WANT);
11189 if ((p->op_private & OPpLVAL_INTRO) != intro)
11191 /* Note that you'd normally expect targs to be
11192 * contiguous in my($a,$b,$c), but that's not the case
11193 * when external modules start doing things, e.g.
11194 i* Function::Parameters */
11195 if (p->op_targ != base + count)
11197 assert(p->op_targ == base + count);
11198 /* all the padops should be in the same context */
11199 if (gimme != (p->op_flags & OPf_WANT))
11203 /* for AV, HV, only when we're not flattening */
11204 if ( p->op_type != OP_PADSV
11205 && gimme != OPf_WANT_VOID
11206 && !(p->op_flags & OPf_REF)
11210 if (count >= OPpPADRANGE_COUNTMASK)
11213 /* there's a biggest base we can fit into a
11214 * SAVEt_CLEARPADRANGE in pp_padrange */
11215 if (intro && base >
11216 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11219 /* Success! We've got another valid pad op to optimise away */
11221 followop = p->op_next;
11227 /* pp_padrange in specifically compile-time void context
11228 * skips pushing a mark and lexicals; in all other contexts
11229 * (including unknown till runtime) it pushes a mark and the
11230 * lexicals. We must be very careful then, that the ops we
11231 * optimise away would have exactly the same effect as the
11233 * In particular in void context, we can only optimise to
11234 * a padrange if see see the complete sequence
11235 * pushmark, pad*v, ...., list, nextstate
11236 * which has the net effect of of leaving the stack empty
11237 * (for now we leave the nextstate in the execution chain, for
11238 * its other side-effects).
11241 if (gimme == OPf_WANT_VOID) {
11242 if (followop->op_type == OP_LIST
11243 && gimme == (followop->op_flags & OPf_WANT)
11244 && ( followop->op_next->op_type == OP_NEXTSTATE
11245 || followop->op_next->op_type == OP_DBSTATE))
11247 followop = followop->op_next; /* skip OP_LIST */
11249 /* consolidate two successive my(...);'s */
11252 && oldoldop->op_type == OP_PADRANGE
11253 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11254 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11255 && !(oldoldop->op_flags & OPf_SPECIAL)
11258 assert(oldoldop->op_next == oldop);
11259 assert( oldop->op_type == OP_NEXTSTATE
11260 || oldop->op_type == OP_DBSTATE);
11261 assert(oldop->op_next == o);
11264 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11266 /* Do not assume pad offsets for $c and $d are con-
11271 if ( oldoldop->op_targ + old_count == base
11272 && old_count < OPpPADRANGE_COUNTMASK - count) {
11273 base = oldoldop->op_targ;
11274 count += old_count;
11279 /* if there's any immediately following singleton
11280 * my var's; then swallow them and the associated
11282 * my ($a,$b); my $c; my $d;
11284 * my ($a,$b,$c,$d);
11287 while ( ((p = followop->op_next))
11288 && ( p->op_type == OP_PADSV
11289 || p->op_type == OP_PADAV
11290 || p->op_type == OP_PADHV)
11291 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11292 && (p->op_private & OPpLVAL_INTRO) == intro
11294 && ( p->op_next->op_type == OP_NEXTSTATE
11295 || p->op_next->op_type == OP_DBSTATE)
11296 && count < OPpPADRANGE_COUNTMASK
11297 && base + count == p->op_targ
11300 followop = p->op_next;
11308 assert(oldoldop->op_type == OP_PADRANGE);
11309 oldoldop->op_next = followop;
11310 oldoldop->op_private = (intro | count);
11316 /* Convert the pushmark into a padrange.
11317 * To make Deparse easier, we guarantee that a padrange was
11318 * *always* formerly a pushmark */
11319 assert(o->op_type == OP_PUSHMARK);
11320 o->op_next = followop;
11321 o->op_type = OP_PADRANGE;
11322 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11324 /* bit 7: INTRO; bit 6..0: count */
11325 o->op_private = (intro | count);
11326 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11327 | gimme | (defav ? OPf_SPECIAL : 0));
11334 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11335 OP* const pop = (o->op_type == OP_PADAV) ?
11336 o->op_next : o->op_next->op_next;
11338 if (pop && pop->op_type == OP_CONST &&
11339 ((PL_op = pop->op_next)) &&
11340 pop->op_next->op_type == OP_AELEM &&
11341 !(pop->op_next->op_private &
11342 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11343 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11346 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11347 no_bareword_allowed(pop);
11348 if (o->op_type == OP_GV)
11349 op_null(o->op_next);
11350 op_null(pop->op_next);
11352 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11353 o->op_next = pop->op_next->op_next;
11354 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11355 o->op_private = (U8)i;
11356 if (o->op_type == OP_GV) {
11359 o->op_type = OP_AELEMFAST;
11362 o->op_type = OP_AELEMFAST_LEX;
11367 if (o->op_next->op_type == OP_RV2SV) {
11368 if (!(o->op_next->op_private & OPpDEREF)) {
11369 op_null(o->op_next);
11370 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11372 o->op_next = o->op_next->op_next;
11373 o->op_type = OP_GVSV;
11374 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11377 else if (o->op_next->op_type == OP_READLINE
11378 && o->op_next->op_next->op_type == OP_CONCAT
11379 && (o->op_next->op_next->op_flags & OPf_STACKED))
11381 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11382 o->op_type = OP_RCATLINE;
11383 o->op_flags |= OPf_STACKED;
11384 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11385 op_null(o->op_next->op_next);
11386 op_null(o->op_next);
11395 #define HV_OR_SCALARHV(op) \
11396 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11398 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11399 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11400 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11401 ? cUNOPx(op)->op_first \
11405 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11406 fop->op_private |= OPpTRUEBOOL;
11412 fop = cLOGOP->op_first;
11413 sop = fop->op_sibling;
11414 while (cLOGOP->op_other->op_type == OP_NULL)
11415 cLOGOP->op_other = cLOGOP->op_other->op_next;
11416 while (o->op_next && ( o->op_type == o->op_next->op_type
11417 || o->op_next->op_type == OP_NULL))
11418 o->op_next = o->op_next->op_next;
11419 DEFER(cLOGOP->op_other);
11422 fop = HV_OR_SCALARHV(fop);
11423 if (sop) sop = HV_OR_SCALARHV(sop);
11428 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11429 while (nop && nop->op_next) {
11430 switch (nop->op_next->op_type) {
11435 lop = nop = nop->op_next;
11438 nop = nop->op_next;
11447 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11448 || o->op_type == OP_AND )
11449 fop->op_private |= OPpTRUEBOOL;
11450 else if (!(lop->op_flags & OPf_WANT))
11451 fop->op_private |= OPpMAYBE_TRUEBOOL;
11453 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11455 sop->op_private |= OPpTRUEBOOL;
11462 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11463 fop->op_private |= OPpTRUEBOOL;
11464 #undef HV_OR_SCALARHV
11475 while (cLOGOP->op_other->op_type == OP_NULL)
11476 cLOGOP->op_other = cLOGOP->op_other->op_next;
11477 DEFER(cLOGOP->op_other);
11482 while (cLOOP->op_redoop->op_type == OP_NULL)
11483 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11484 while (cLOOP->op_nextop->op_type == OP_NULL)
11485 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11486 while (cLOOP->op_lastop->op_type == OP_NULL)
11487 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11488 /* a while(1) loop doesn't have an op_next that escapes the
11489 * loop, so we have to explicitly follow the op_lastop to
11490 * process the rest of the code */
11491 DEFER(cLOOP->op_lastop);
11495 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11496 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11497 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11498 cPMOP->op_pmstashstartu.op_pmreplstart
11499 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11500 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11506 if (o->op_flags & OPf_STACKED) {
11508 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11509 if (kid->op_type == OP_SCOPE
11510 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11511 DEFER(kLISTOP->op_first);
11514 /* check that RHS of sort is a single plain array */
11515 oright = cUNOPo->op_first;
11516 if (!oright || oright->op_type != OP_PUSHMARK)
11519 if (o->op_private & OPpSORT_INPLACE)
11522 /* reverse sort ... can be optimised. */
11523 if (!cUNOPo->op_sibling) {
11524 /* Nothing follows us on the list. */
11525 OP * const reverse = o->op_next;
11527 if (reverse->op_type == OP_REVERSE &&
11528 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11529 OP * const pushmark = cUNOPx(reverse)->op_first;
11530 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11531 && (cUNOPx(pushmark)->op_sibling == o)) {
11532 /* reverse -> pushmark -> sort */
11533 o->op_private |= OPpSORT_REVERSE;
11535 pushmark->op_next = oright->op_next;
11545 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11547 LISTOP *enter, *exlist;
11549 if (o->op_private & OPpSORT_INPLACE)
11552 enter = (LISTOP *) o->op_next;
11555 if (enter->op_type == OP_NULL) {
11556 enter = (LISTOP *) enter->op_next;
11560 /* for $a (...) will have OP_GV then OP_RV2GV here.
11561 for (...) just has an OP_GV. */
11562 if (enter->op_type == OP_GV) {
11563 gvop = (OP *) enter;
11564 enter = (LISTOP *) enter->op_next;
11567 if (enter->op_type == OP_RV2GV) {
11568 enter = (LISTOP *) enter->op_next;
11574 if (enter->op_type != OP_ENTERITER)
11577 iter = enter->op_next;
11578 if (!iter || iter->op_type != OP_ITER)
11581 expushmark = enter->op_first;
11582 if (!expushmark || expushmark->op_type != OP_NULL
11583 || expushmark->op_targ != OP_PUSHMARK)
11586 exlist = (LISTOP *) expushmark->op_sibling;
11587 if (!exlist || exlist->op_type != OP_NULL
11588 || exlist->op_targ != OP_LIST)
11591 if (exlist->op_last != o) {
11592 /* Mmm. Was expecting to point back to this op. */
11595 theirmark = exlist->op_first;
11596 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11599 if (theirmark->op_sibling != o) {
11600 /* There's something between the mark and the reverse, eg
11601 for (1, reverse (...))
11606 ourmark = ((LISTOP *)o)->op_first;
11607 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11610 ourlast = ((LISTOP *)o)->op_last;
11611 if (!ourlast || ourlast->op_next != o)
11614 rv2av = ourmark->op_sibling;
11615 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11616 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11617 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11618 /* We're just reversing a single array. */
11619 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11620 enter->op_flags |= OPf_STACKED;
11623 /* We don't have control over who points to theirmark, so sacrifice
11625 theirmark->op_next = ourmark->op_next;
11626 theirmark->op_flags = ourmark->op_flags;
11627 ourlast->op_next = gvop ? gvop : (OP *) enter;
11630 enter->op_private |= OPpITER_REVERSED;
11631 iter->op_private |= OPpITER_REVERSED;
11638 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11639 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11644 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11646 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11648 sv = newRV((SV *)PL_compcv);
11652 o->op_type = OP_CONST;
11653 o->op_ppaddr = PL_ppaddr[OP_CONST];
11654 o->op_flags |= OPf_SPECIAL;
11655 cSVOPo->op_sv = sv;
11660 if (OP_GIMME(o,0) == G_VOID) {
11661 OP *right = cBINOP->op_first;
11663 OP *left = right->op_sibling;
11664 if (left->op_type == OP_SUBSTR
11665 && (left->op_private & 7) < 4) {
11667 cBINOP->op_first = left;
11668 right->op_sibling =
11669 cBINOPx(left)->op_first->op_sibling;
11670 cBINOPx(left)->op_first->op_sibling = right;
11671 left->op_private |= OPpSUBSTR_REPL_FIRST;
11673 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11680 Perl_cpeep_t cpeep =
11681 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11683 cpeep(aTHX_ o, oldop);
11695 Perl_peep(pTHX_ OP *o)
11701 =head1 Custom Operators
11703 =for apidoc Ao||custom_op_xop
11704 Return the XOP structure for a given custom op. This function should be
11705 considered internal to OP_NAME and the other access macros: use them instead.
11711 Perl_custom_op_xop(pTHX_ const OP *o)
11717 static const XOP xop_null = { 0, 0, 0, 0, 0 };
11719 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11720 assert(o->op_type == OP_CUSTOM);
11722 /* This is wrong. It assumes a function pointer can be cast to IV,
11723 * which isn't guaranteed, but this is what the old custom OP code
11724 * did. In principle it should be safer to Copy the bytes of the
11725 * pointer into a PV: since the new interface is hidden behind
11726 * functions, this can be changed later if necessary. */
11727 /* Change custom_op_xop if this ever happens */
11728 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11731 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11733 /* assume noone will have just registered a desc */
11734 if (!he && PL_custom_op_names &&
11735 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11740 /* XXX does all this need to be shared mem? */
11741 Newxz(xop, 1, XOP);
11742 pv = SvPV(HeVAL(he), l);
11743 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11744 if (PL_custom_op_descs &&
11745 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11747 pv = SvPV(HeVAL(he), l);
11748 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11750 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11754 if (!he) return &xop_null;
11756 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11761 =for apidoc Ao||custom_op_register
11762 Register a custom op. See L<perlguts/"Custom Operators">.
11768 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11772 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11774 /* see the comment in custom_op_xop */
11775 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11777 if (!PL_custom_ops)
11778 PL_custom_ops = newHV();
11780 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11781 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11785 =head1 Functions in file op.c
11787 =for apidoc core_prototype
11788 This function assigns the prototype of the named core function to C<sv>, or
11789 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
11790 NULL if the core function has no prototype. C<code> is a code as returned
11791 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
11797 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11800 int i = 0, n = 0, seen_question = 0, defgv = 0;
11802 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11803 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11804 bool nullret = FALSE;
11806 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11808 assert (code && code != -KEY_CORE);
11810 if (!sv) sv = sv_newmortal();
11812 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11814 switch (code < 0 ? -code : code) {
11815 case KEY_and : case KEY_chop: case KEY_chomp:
11816 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11817 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11818 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11819 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11820 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11821 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11822 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11823 case KEY_x : case KEY_xor :
11824 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11825 case KEY_glob: retsetpvs("_;", OP_GLOB);
11826 case KEY_keys: retsetpvs("+", OP_KEYS);
11827 case KEY_values: retsetpvs("+", OP_VALUES);
11828 case KEY_each: retsetpvs("+", OP_EACH);
11829 case KEY_push: retsetpvs("+@", OP_PUSH);
11830 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11831 case KEY_pop: retsetpvs(";+", OP_POP);
11832 case KEY_shift: retsetpvs(";+", OP_SHIFT);
11833 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
11835 retsetpvs("+;$$@", OP_SPLICE);
11836 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11838 case KEY_evalbytes:
11839 name = "entereval"; break;
11847 while (i < MAXO) { /* The slow way. */
11848 if (strEQ(name, PL_op_name[i])
11849 || strEQ(name, PL_op_desc[i]))
11851 if (nullret) { assert(opnum); *opnum = i; return NULL; }
11858 defgv = PL_opargs[i] & OA_DEFGV;
11859 oa = PL_opargs[i] >> OASHIFT;
11861 if (oa & OA_OPTIONAL && !seen_question && (
11862 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11867 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11868 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11869 /* But globs are already references (kinda) */
11870 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11874 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11875 && !scalar_mod_type(NULL, i)) {
11880 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11884 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11885 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11886 str[n-1] = '_'; defgv = 0;
11890 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11892 sv_setpvn(sv, str, n - 1);
11893 if (opnum) *opnum = i;
11898 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11901 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11904 PERL_ARGS_ASSERT_CORESUB_OP;
11908 return op_append_elem(OP_LINESEQ,
11911 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11915 case OP_SELECT: /* which represents OP_SSELECT as well */
11920 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11921 newSVOP(OP_CONST, 0, newSVuv(1))
11923 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11925 coresub_op(coreargssv, 0, OP_SELECT)
11929 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11931 return op_append_elem(
11934 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11935 ? OPpOFFBYONE << 8 : 0)
11937 case OA_BASEOP_OR_UNOP:
11938 if (opnum == OP_ENTEREVAL) {
11939 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11940 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11942 else o = newUNOP(opnum,0,argop);
11943 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11946 if (is_handle_constructor(o, 1))
11947 argop->op_private |= OPpCOREARGS_DEREF1;
11948 if (scalar_mod_type(NULL, opnum))
11949 argop->op_private |= OPpCOREARGS_SCALARMOD;
11953 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11954 if (is_handle_constructor(o, 2))
11955 argop->op_private |= OPpCOREARGS_DEREF2;
11956 if (opnum == OP_SUBSTR) {
11957 o->op_private |= OPpMAYBE_LVSUB;
11966 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11967 SV * const *new_const_svp)
11969 const char *hvname;
11970 bool is_const = !!CvCONST(old_cv);
11971 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11973 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11975 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11977 /* They are 2 constant subroutines generated from
11978 the same constant. This probably means that
11979 they are really the "same" proxy subroutine
11980 instantiated in 2 places. Most likely this is
11981 when a constant is exported twice. Don't warn.
11984 (ckWARN(WARN_REDEFINE)
11986 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11987 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11988 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11989 strEQ(hvname, "autouse"))
11993 && ckWARN_d(WARN_REDEFINE)
11994 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11997 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11999 ? "Constant subroutine %"SVf" redefined"
12000 : "Subroutine %"SVf" redefined",
12005 =head1 Hook manipulation
12007 These functions provide convenient and thread-safe means of manipulating
12014 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12016 Puts a C function into the chain of check functions for a specified op
12017 type. This is the preferred way to manipulate the L</PL_check> array.
12018 I<opcode> specifies which type of op is to be affected. I<new_checker>
12019 is a pointer to the C function that is to be added to that opcode's
12020 check chain, and I<old_checker_p> points to the storage location where a
12021 pointer to the next function in the chain will be stored. The value of
12022 I<new_pointer> is written into the L</PL_check> array, while the value
12023 previously stored there is written to I<*old_checker_p>.
12025 L</PL_check> is global to an entire process, and a module wishing to
12026 hook op checking may find itself invoked more than once per process,
12027 typically in different threads. To handle that situation, this function
12028 is idempotent. The location I<*old_checker_p> must initially (once
12029 per process) contain a null pointer. A C variable of static duration
12030 (declared at file scope, typically also marked C<static> to give
12031 it internal linkage) will be implicitly initialised appropriately,
12032 if it does not have an explicit initialiser. This function will only
12033 actually modify the check chain if it finds I<*old_checker_p> to be null.
12034 This function is also thread safe on the small scale. It uses appropriate
12035 locking to avoid race conditions in accessing L</PL_check>.
12037 When this function is called, the function referenced by I<new_checker>
12038 must be ready to be called, except for I<*old_checker_p> being unfilled.
12039 In a threading situation, I<new_checker> may be called immediately,
12040 even before this function has returned. I<*old_checker_p> will always
12041 be appropriately set before I<new_checker> is called. If I<new_checker>
12042 decides not to do anything special with an op that it is given (which
12043 is the usual case for most uses of op check hooking), it must chain the
12044 check function referenced by I<*old_checker_p>.
12046 If you want to influence compilation of calls to a specific subroutine,
12047 then use L</cv_set_call_checker> rather than hooking checking of all
12054 Perl_wrap_op_checker(pTHX_ Optype opcode,
12055 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12059 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12060 if (*old_checker_p) return;
12061 OP_CHECK_MUTEX_LOCK;
12062 if (!*old_checker_p) {
12063 *old_checker_p = PL_check[opcode];
12064 PL_check[opcode] = new_checker;
12066 OP_CHECK_MUTEX_UNLOCK;
12071 /* Efficient sub that returns a constant scalar value. */
12073 const_sv_xsub(pTHX_ CV* cv)
12077 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12078 PERL_UNUSED_ARG(items);
12088 const_av_xsub(pTHX_ CV* cv)
12092 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12100 if (SvRMAGICAL(av))
12101 Perl_croak(aTHX_ "Magical list constants are not supported");
12102 if (GIMME_V != G_ARRAY) {
12104 ST(0) = newSViv((IV)AvFILLp(av)+1);
12107 EXTEND(SP, AvFILLp(av)+1);
12108 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12109 XSRETURN(AvFILLp(av)+1);
12114 * c-indentation-style: bsd
12115 * c-basic-offset: 4
12116 * indent-tabs-mode: nil
12119 * ex: set ts=8 sts=4 sw=4 et: