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"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 mad_free(o->op_madprop);
555 switch (o->op_type) {
556 case OP_NULL: /* Was holding old type, if any. */
557 if (PL_madskills && o->op_targ != OP_NULL) {
558 o->op_type = (Optype)o->op_targ;
563 case OP_ENTEREVAL: /* Was holding hints. */
567 if (!(o->op_flags & OPf_REF)
568 || (PL_check[o->op_type] != Perl_ck_ftst))
574 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
575 /* not an OP_PADAV replacement */
576 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
581 /* It's possible during global destruction that the GV is freed
582 before the optree. Whilst the SvREFCNT_inc is happy to bump from
583 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
584 will trigger an assertion failure, because the entry to sv_clear
585 checks that the scalar is not already freed. A check of for
586 !SvIS_FREED(gv) turns out to be invalid, because during global
587 destruction the reference count can be forced down to zero
588 (with SVf_BREAK set). In which case raising to 1 and then
589 dropping to 0 triggers cleanup before it should happen. I
590 *think* that this might actually be a general, systematic,
591 weakness of the whole idea of SVf_BREAK, in that code *is*
592 allowed to raise and lower references during global destruction,
593 so any *valid* code that happens to do this during global
594 destruction might well trigger premature cleanup. */
595 bool still_valid = gv && SvREFCNT(gv);
598 SvREFCNT_inc_simple_void(gv);
600 if (cPADOPo->op_padix > 0) {
601 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
602 * may still exist on the pad */
603 pad_swipe(cPADOPo->op_padix, TRUE);
604 cPADOPo->op_padix = 0;
607 SvREFCNT_dec(cSVOPo->op_sv);
608 cSVOPo->op_sv = NULL;
611 int try_downgrade = SvREFCNT(gv) == 2;
614 gv_try_downgrade(gv);
618 case OP_METHOD_NAMED:
621 SvREFCNT_dec(cSVOPo->op_sv);
622 cSVOPo->op_sv = NULL;
625 Even if op_clear does a pad_free for the target of the op,
626 pad_free doesn't actually remove the sv that exists in the pad;
627 instead it lives on. This results in that it could be reused as
628 a target later on when the pad was reallocated.
631 pad_swipe(o->op_targ,1);
640 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
645 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
647 if (cPADOPo->op_padix > 0) {
648 pad_swipe(cPADOPo->op_padix, TRUE);
649 cPADOPo->op_padix = 0;
652 SvREFCNT_dec(cSVOPo->op_sv);
653 cSVOPo->op_sv = NULL;
657 PerlMemShared_free(cPVOPo->op_pv);
658 cPVOPo->op_pv = NULL;
662 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
666 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
667 /* No GvIN_PAD_off here, because other references may still
668 * exist on the pad */
669 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
672 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
678 forget_pmop(cPMOPo, 1);
679 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
680 /* we use the same protection as the "SAFE" version of the PM_ macros
681 * here since sv_clean_all might release some PMOPs
682 * after PL_regex_padav has been cleared
683 * and the clearing of PL_regex_padav needs to
684 * happen before sv_clean_all
687 if(PL_regex_pad) { /* We could be in destruction */
688 const IV offset = (cPMOPo)->op_pmoffset;
689 ReREFCNT_dec(PM_GETRE(cPMOPo));
690 PL_regex_pad[offset] = &PL_sv_undef;
691 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
695 ReREFCNT_dec(PM_GETRE(cPMOPo));
696 PM_SETRE(cPMOPo, NULL);
702 if (o->op_targ > 0) {
703 pad_free(o->op_targ);
709 S_cop_free(pTHX_ COP* cop)
711 PERL_ARGS_ASSERT_COP_FREE;
715 if (! specialWARN(cop->cop_warnings))
716 PerlMemShared_free(cop->cop_warnings);
717 cophh_free(CopHINTHASH_get(cop));
721 S_forget_pmop(pTHX_ PMOP *const o
727 HV * const pmstash = PmopSTASH(o);
729 PERL_ARGS_ASSERT_FORGET_PMOP;
731 if (pmstash && !SvIS_FREED(pmstash)) {
732 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
734 PMOP **const array = (PMOP**) mg->mg_ptr;
735 U32 count = mg->mg_len / sizeof(PMOP**);
740 /* Found it. Move the entry at the end to overwrite it. */
741 array[i] = array[--count];
742 mg->mg_len = count * sizeof(PMOP**);
743 /* Could realloc smaller at this point always, but probably
744 not worth it. Probably worth free()ing if we're the
747 Safefree(mg->mg_ptr);
764 S_find_and_forget_pmops(pTHX_ OP *o)
766 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
768 if (o->op_flags & OPf_KIDS) {
769 OP *kid = cUNOPo->op_first;
771 switch (kid->op_type) {
776 forget_pmop((PMOP*)kid, 0);
778 find_and_forget_pmops(kid);
779 kid = kid->op_sibling;
785 Perl_op_null(pTHX_ OP *o)
789 PERL_ARGS_ASSERT_OP_NULL;
791 if (o->op_type == OP_NULL)
795 o->op_targ = o->op_type;
796 o->op_type = OP_NULL;
797 o->op_ppaddr = PL_ppaddr[OP_NULL];
801 Perl_op_refcnt_lock(pTHX)
809 Perl_op_refcnt_unlock(pTHX)
816 /* Contextualizers */
819 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
821 Applies a syntactic context to an op tree representing an expression.
822 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
823 or C<G_VOID> to specify the context to apply. The modified op tree
830 Perl_op_contextualize(pTHX_ OP *o, I32 context)
832 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
834 case G_SCALAR: return scalar(o);
835 case G_ARRAY: return list(o);
836 case G_VOID: return scalarvoid(o);
838 Perl_croak(aTHX_ "panic: op_contextualize bad context");
844 =head1 Optree Manipulation Functions
846 =for apidoc Am|OP*|op_linklist|OP *o
847 This function is the implementation of the L</LINKLIST> macro. It should
848 not be called directly.
854 Perl_op_linklist(pTHX_ OP *o)
858 PERL_ARGS_ASSERT_OP_LINKLIST;
863 /* establish postfix order */
864 first = cUNOPo->op_first;
867 o->op_next = LINKLIST(first);
870 if (kid->op_sibling) {
871 kid->op_next = LINKLIST(kid->op_sibling);
872 kid = kid->op_sibling;
886 S_scalarkids(pTHX_ OP *o)
888 if (o && o->op_flags & OPf_KIDS) {
890 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
897 S_scalarboolean(pTHX_ OP *o)
901 PERL_ARGS_ASSERT_SCALARBOOLEAN;
903 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
904 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
905 if (ckWARN(WARN_SYNTAX)) {
906 const line_t oldline = CopLINE(PL_curcop);
908 if (PL_parser && PL_parser->copline != NOLINE)
909 CopLINE_set(PL_curcop, PL_parser->copline);
910 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
911 CopLINE_set(PL_curcop, oldline);
918 Perl_scalar(pTHX_ OP *o)
923 /* assumes no premature commitment */
924 if (!o || (PL_parser && PL_parser->error_count)
925 || (o->op_flags & OPf_WANT)
926 || o->op_type == OP_RETURN)
931 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
933 switch (o->op_type) {
935 scalar(cBINOPo->op_first);
940 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
950 if (o->op_flags & OPf_KIDS) {
951 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
957 kid = cLISTOPo->op_first;
959 kid = kid->op_sibling;
962 OP *sib = kid->op_sibling;
963 if (sib && kid->op_type != OP_LEAVEWHEN) {
964 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
974 PL_curcop = &PL_compiling;
979 kid = cLISTOPo->op_first;
982 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
989 Perl_scalarvoid(pTHX_ OP *o)
993 const char* useless = NULL;
997 PERL_ARGS_ASSERT_SCALARVOID;
999 /* trailing mad null ops don't count as "there" for void processing */
1001 o->op_type != OP_NULL &&
1003 o->op_sibling->op_type == OP_NULL)
1006 for (sib = o->op_sibling;
1007 sib && sib->op_type == OP_NULL;
1008 sib = sib->op_sibling) ;
1014 if (o->op_type == OP_NEXTSTATE
1015 || o->op_type == OP_DBSTATE
1016 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1017 || o->op_targ == OP_DBSTATE)))
1018 PL_curcop = (COP*)o; /* for warning below */
1020 /* assumes no premature commitment */
1021 want = o->op_flags & OPf_WANT;
1022 if ((want && want != OPf_WANT_SCALAR)
1023 || (PL_parser && PL_parser->error_count)
1024 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1029 if ((o->op_private & OPpTARGET_MY)
1030 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1032 return scalar(o); /* As if inside SASSIGN */
1035 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1037 switch (o->op_type) {
1039 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1043 if (o->op_flags & OPf_STACKED)
1047 if (o->op_private == 4)
1090 case OP_GETSOCKNAME:
1091 case OP_GETPEERNAME:
1096 case OP_GETPRIORITY:
1120 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1121 /* Otherwise it's "Useless use of grep iterator" */
1122 useless = OP_DESC(o);
1126 kid = cLISTOPo->op_first;
1127 if (kid && kid->op_type == OP_PUSHRE
1129 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1131 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1133 useless = OP_DESC(o);
1137 kid = cUNOPo->op_first;
1138 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1139 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1142 useless = "negative pattern binding (!~)";
1146 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1147 useless = "non-destructive substitution (s///r)";
1151 useless = "non-destructive transliteration (tr///r)";
1158 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1159 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1160 useless = "a variable";
1165 if (cSVOPo->op_private & OPpCONST_STRICT)
1166 no_bareword_allowed(o);
1168 if (ckWARN(WARN_VOID)) {
1170 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1171 "a constant (%"SVf")", sv));
1172 useless = SvPV_nolen(msv);
1175 useless = "a constant (undef)";
1176 if (o->op_private & OPpCONST_ARYBASE)
1178 /* don't warn on optimised away booleans, eg
1179 * use constant Foo, 5; Foo || print; */
1180 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1182 /* the constants 0 and 1 are permitted as they are
1183 conventionally used as dummies in constructs like
1184 1 while some_condition_with_side_effects; */
1185 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1187 else if (SvPOK(sv)) {
1188 /* perl4's way of mixing documentation and code
1189 (before the invention of POD) was based on a
1190 trick to mix nroff and perl code. The trick was
1191 built upon these three nroff macros being used in
1192 void context. The pink camel has the details in
1193 the script wrapman near page 319. */
1194 const char * const maybe_macro = SvPVX_const(sv);
1195 if (strnEQ(maybe_macro, "di", 2) ||
1196 strnEQ(maybe_macro, "ds", 2) ||
1197 strnEQ(maybe_macro, "ig", 2))
1202 op_null(o); /* don't execute or even remember it */
1206 o->op_type = OP_PREINC; /* pre-increment is faster */
1207 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1211 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1212 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1216 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1221 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1222 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1227 kid = cLOGOPo->op_first;
1228 if (kid->op_type == OP_NOT
1229 && (kid->op_flags & OPf_KIDS)
1231 if (o->op_type == OP_AND) {
1233 o->op_ppaddr = PL_ppaddr[OP_OR];
1235 o->op_type = OP_AND;
1236 o->op_ppaddr = PL_ppaddr[OP_AND];
1245 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1250 if (o->op_flags & OPf_STACKED)
1257 if (!(o->op_flags & OPf_KIDS))
1268 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1278 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1283 S_listkids(pTHX_ OP *o)
1285 if (o && o->op_flags & OPf_KIDS) {
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1294 Perl_list(pTHX_ OP *o)
1299 /* assumes no premature commitment */
1300 if (!o || (o->op_flags & OPf_WANT)
1301 || (PL_parser && PL_parser->error_count)
1302 || o->op_type == OP_RETURN)
1307 if ((o->op_private & OPpTARGET_MY)
1308 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1310 return o; /* As if inside SASSIGN */
1313 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1315 switch (o->op_type) {
1318 list(cBINOPo->op_first);
1323 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1331 if (!(o->op_flags & OPf_KIDS))
1333 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1334 list(cBINOPo->op_first);
1335 return gen_constant_list(o);
1342 kid = cLISTOPo->op_first;
1344 kid = kid->op_sibling;
1347 OP *sib = kid->op_sibling;
1348 if (sib && kid->op_type != OP_LEAVEWHEN) {
1349 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1359 PL_curcop = &PL_compiling;
1363 kid = cLISTOPo->op_first;
1370 S_scalarseq(pTHX_ OP *o)
1374 const OPCODE type = o->op_type;
1376 if (type == OP_LINESEQ || type == OP_SCOPE ||
1377 type == OP_LEAVE || type == OP_LEAVETRY)
1380 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1381 if (kid->op_sibling) {
1385 PL_curcop = &PL_compiling;
1387 o->op_flags &= ~OPf_PARENS;
1388 if (PL_hints & HINT_BLOCK_SCOPE)
1389 o->op_flags |= OPf_PARENS;
1392 o = newOP(OP_STUB, 0);
1397 S_modkids(pTHX_ OP *o, I32 type)
1399 if (o && o->op_flags & OPf_KIDS) {
1401 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1402 op_lvalue(kid, type);
1408 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1410 Propagate lvalue ("modifiable") context to an op and its children.
1411 I<type> represents the context type, roughly based on the type of op that
1412 would do the modifying, although C<local()> is represented by OP_NULL,
1413 because it has no op type of its own (it is signalled by a flag on
1416 This function detects things that can't be modified, such as C<$x+1>, and
1417 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1418 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1420 It also flags things that need to behave specially in an lvalue context,
1421 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1427 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1431 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1434 if (!o || (PL_parser && PL_parser->error_count))
1437 if ((o->op_private & OPpTARGET_MY)
1438 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1443 switch (o->op_type) {
1449 if (!(o->op_private & OPpCONST_ARYBASE))
1452 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1453 CopARYBASE_set(&PL_compiling,
1454 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1458 SAVECOPARYBASE(&PL_compiling);
1459 CopARYBASE_set(&PL_compiling, 0);
1461 else if (type == OP_REFGEN)
1464 Perl_croak(aTHX_ "That use of $[ is unsupported");
1467 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1471 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1472 !(o->op_flags & OPf_STACKED)) {
1473 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1474 /* The default is to set op_private to the number of children,
1475 which for a UNOP such as RV2CV is always 1. And w're using
1476 the bit for a flag in RV2CV, so we need it clear. */
1477 o->op_private &= ~1;
1478 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479 assert(cUNOPo->op_first->op_type == OP_NULL);
1480 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1483 else if (o->op_private & OPpENTERSUB_NOMOD)
1485 else { /* lvalue subroutine call */
1486 o->op_private |= OPpLVAL_INTRO;
1487 PL_modcount = RETURN_UNLIMITED_NUMBER;
1488 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1489 /* Backward compatibility mode: */
1490 o->op_private |= OPpENTERSUB_INARGS;
1493 else { /* Compile-time error message: */
1494 OP *kid = cUNOPo->op_first;
1498 if (kid->op_type != OP_PUSHMARK) {
1499 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1501 "panic: unexpected lvalue entersub "
1502 "args: type/targ %ld:%"UVuf,
1503 (long)kid->op_type, (UV)kid->op_targ);
1504 kid = kLISTOP->op_first;
1506 while (kid->op_sibling)
1507 kid = kid->op_sibling;
1508 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1510 if (kid->op_type == OP_METHOD_NAMED
1511 || kid->op_type == OP_METHOD)
1515 NewOp(1101, newop, 1, UNOP);
1516 newop->op_type = OP_RV2CV;
1517 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1518 newop->op_first = NULL;
1519 newop->op_next = (OP*)newop;
1520 kid->op_sibling = (OP*)newop;
1521 newop->op_private |= OPpLVAL_INTRO;
1522 newop->op_private &= ~1;
1526 if (kid->op_type != OP_RV2CV)
1528 "panic: unexpected lvalue entersub "
1529 "entry via type/targ %ld:%"UVuf,
1530 (long)kid->op_type, (UV)kid->op_targ);
1531 kid->op_private |= OPpLVAL_INTRO;
1532 break; /* Postpone until runtime */
1536 kid = kUNOP->op_first;
1537 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1538 kid = kUNOP->op_first;
1539 if (kid->op_type == OP_NULL)
1541 "Unexpected constant lvalue entersub "
1542 "entry via type/targ %ld:%"UVuf,
1543 (long)kid->op_type, (UV)kid->op_targ);
1544 if (kid->op_type != OP_GV) {
1545 /* Restore RV2CV to check lvalueness */
1547 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1548 okid->op_next = kid->op_next;
1549 kid->op_next = okid;
1552 okid->op_next = NULL;
1553 okid->op_type = OP_RV2CV;
1555 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1556 okid->op_private |= OPpLVAL_INTRO;
1557 okid->op_private &= ~1;
1561 cv = GvCV(kGVOP_gv);
1571 /* grep, foreach, subcalls, refgen */
1572 if (type == OP_GREPSTART || type == OP_ENTERSUB
1573 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1575 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1576 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1578 : (o->op_type == OP_ENTERSUB
1579 ? "non-lvalue subroutine call"
1581 type ? PL_op_desc[type] : "local"));
1595 case OP_RIGHT_SHIFT:
1604 if (!(o->op_flags & OPf_STACKED))
1611 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1612 op_lvalue(kid, type);
1617 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1618 PL_modcount = RETURN_UNLIMITED_NUMBER;
1619 return o; /* Treat \(@foo) like ordinary list. */
1623 if (scalar_mod_type(o, type))
1625 ref(cUNOPo->op_first, o->op_type);
1629 if (type == OP_LEAVESUBLV)
1630 o->op_private |= OPpMAYBE_LVSUB;
1636 PL_modcount = RETURN_UNLIMITED_NUMBER;
1639 PL_hints |= HINT_BLOCK_SCOPE;
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1645 ref(cUNOPo->op_first, o->op_type);
1649 PL_hints |= HINT_BLOCK_SCOPE;
1664 PL_modcount = RETURN_UNLIMITED_NUMBER;
1665 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1666 return o; /* Treat \(@foo) like ordinary list. */
1667 if (scalar_mod_type(o, type))
1669 if (type == OP_LEAVESUBLV)
1670 o->op_private |= OPpMAYBE_LVSUB;
1674 if (!type) /* local() */
1675 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1676 PAD_COMPNAME_PV(o->op_targ));
1685 if (type != OP_SASSIGN)
1689 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1694 if (type == OP_LEAVESUBLV)
1695 o->op_private |= OPpMAYBE_LVSUB;
1697 pad_free(o->op_targ);
1698 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1699 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1700 if (o->op_flags & OPf_KIDS)
1701 op_lvalue(cBINOPo->op_first->op_sibling, type);
1706 ref(cBINOPo->op_first, o->op_type);
1707 if (type == OP_ENTERSUB &&
1708 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1709 o->op_private |= OPpLVAL_DEFER;
1710 if (type == OP_LEAVESUBLV)
1711 o->op_private |= OPpMAYBE_LVSUB;
1721 if (o->op_flags & OPf_KIDS)
1722 op_lvalue(cLISTOPo->op_last, type);
1727 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1729 else if (!(o->op_flags & OPf_KIDS))
1731 if (o->op_targ != OP_LIST) {
1732 op_lvalue(cBINOPo->op_first, type);
1738 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1739 op_lvalue(kid, type);
1743 if (type != OP_LEAVESUBLV)
1745 break; /* op_lvalue()ing was handled by ck_return() */
1748 /* [20011101.069] File test operators interpret OPf_REF to mean that
1749 their argument is a filehandle; thus \stat(".") should not set
1751 if (type == OP_REFGEN &&
1752 PL_check[o->op_type] == Perl_ck_ftst)
1755 if (type != OP_LEAVESUBLV)
1756 o->op_flags |= OPf_MOD;
1758 if (type == OP_AASSIGN || type == OP_SASSIGN)
1759 o->op_flags |= OPf_SPECIAL|OPf_REF;
1760 else if (!type) { /* local() */
1763 o->op_private |= OPpLVAL_INTRO;
1764 o->op_flags &= ~OPf_SPECIAL;
1765 PL_hints |= HINT_BLOCK_SCOPE;
1770 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1771 "Useless localization of %s", OP_DESC(o));
1774 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1775 && type != OP_LEAVESUBLV)
1776 o->op_flags |= OPf_REF;
1780 /* Do not use this. It will be removed after 5.14. */
1782 Perl_mod(pTHX_ OP *o, I32 type)
1784 return op_lvalue(o,type);
1789 S_scalar_mod_type(const OP *o, I32 type)
1791 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1795 if (o->op_type == OP_RV2GV)
1819 case OP_RIGHT_SHIFT:
1840 S_is_handle_constructor(const OP *o, I32 numargs)
1842 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1844 switch (o->op_type) {
1852 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1865 S_refkids(pTHX_ OP *o, I32 type)
1867 if (o && o->op_flags & OPf_KIDS) {
1869 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1876 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1881 PERL_ARGS_ASSERT_DOREF;
1883 if (!o || (PL_parser && PL_parser->error_count))
1886 switch (o->op_type) {
1888 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1889 !(o->op_flags & OPf_STACKED)) {
1890 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1891 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1892 assert(cUNOPo->op_first->op_type == OP_NULL);
1893 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1894 o->op_flags |= OPf_SPECIAL;
1895 o->op_private &= ~1;
1900 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1901 doref(kid, type, set_op_ref);
1904 if (type == OP_DEFINED)
1905 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1906 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1909 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1910 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1911 : type == OP_RV2HV ? OPpDEREF_HV
1913 o->op_flags |= OPf_MOD;
1920 o->op_flags |= OPf_REF;
1923 if (type == OP_DEFINED)
1924 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1925 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1931 o->op_flags |= OPf_REF;
1936 if (!(o->op_flags & OPf_KIDS))
1938 doref(cBINOPo->op_first, type, set_op_ref);
1942 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1943 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1944 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1945 : type == OP_RV2HV ? OPpDEREF_HV
1947 o->op_flags |= OPf_MOD;
1957 if (!(o->op_flags & OPf_KIDS))
1959 doref(cLISTOPo->op_last, type, set_op_ref);
1969 S_dup_attrlist(pTHX_ OP *o)
1974 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1976 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1977 * where the first kid is OP_PUSHMARK and the remaining ones
1978 * are OP_CONST. We need to push the OP_CONST values.
1980 if (o->op_type == OP_CONST)
1981 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1983 else if (o->op_type == OP_NULL)
1987 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1989 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1990 if (o->op_type == OP_CONST)
1991 rop = op_append_elem(OP_LIST, rop,
1992 newSVOP(OP_CONST, o->op_flags,
1993 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2000 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2005 PERL_ARGS_ASSERT_APPLY_ATTRS;
2007 /* fake up C<use attributes $pkg,$rv,@attrs> */
2008 ENTER; /* need to protect against side-effects of 'use' */
2009 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2011 #define ATTRSMODULE "attributes"
2012 #define ATTRSMODULE_PM "attributes.pm"
2015 /* Don't force the C<use> if we don't need it. */
2016 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2017 if (svp && *svp != &PL_sv_undef)
2018 NOOP; /* already in %INC */
2020 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2021 newSVpvs(ATTRSMODULE), NULL);
2024 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2025 newSVpvs(ATTRSMODULE),
2027 op_prepend_elem(OP_LIST,
2028 newSVOP(OP_CONST, 0, stashsv),
2029 op_prepend_elem(OP_LIST,
2030 newSVOP(OP_CONST, 0,
2032 dup_attrlist(attrs))));
2038 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2041 OP *pack, *imop, *arg;
2044 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2049 assert(target->op_type == OP_PADSV ||
2050 target->op_type == OP_PADHV ||
2051 target->op_type == OP_PADAV);
2053 /* Ensure that attributes.pm is loaded. */
2054 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2056 /* Need package name for method call. */
2057 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2059 /* Build up the real arg-list. */
2060 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2062 arg = newOP(OP_PADSV, 0);
2063 arg->op_targ = target->op_targ;
2064 arg = op_prepend_elem(OP_LIST,
2065 newSVOP(OP_CONST, 0, stashsv),
2066 op_prepend_elem(OP_LIST,
2067 newUNOP(OP_REFGEN, 0,
2068 op_lvalue(arg, OP_REFGEN)),
2069 dup_attrlist(attrs)));
2071 /* Fake up a method call to import */
2072 meth = newSVpvs_share("import");
2073 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2074 op_append_elem(OP_LIST,
2075 op_prepend_elem(OP_LIST, pack, list(arg)),
2076 newSVOP(OP_METHOD_NAMED, 0, meth)));
2077 imop->op_private |= OPpENTERSUB_NOMOD;
2079 /* Combine the ops. */
2080 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2084 =notfor apidoc apply_attrs_string
2086 Attempts to apply a list of attributes specified by the C<attrstr> and
2087 C<len> arguments to the subroutine identified by the C<cv> argument which
2088 is expected to be associated with the package identified by the C<stashpv>
2089 argument (see L<attributes>). It gets this wrong, though, in that it
2090 does not correctly identify the boundaries of the individual attribute
2091 specifications within C<attrstr>. This is not really intended for the
2092 public API, but has to be listed here for systems such as AIX which
2093 need an explicit export list for symbols. (It's called from XS code
2094 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2095 to respect attribute syntax properly would be welcome.
2101 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2102 const char *attrstr, STRLEN len)
2106 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2109 len = strlen(attrstr);
2113 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2115 const char * const sstr = attrstr;
2116 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2117 attrs = op_append_elem(OP_LIST, attrs,
2118 newSVOP(OP_CONST, 0,
2119 newSVpvn(sstr, attrstr-sstr)));
2123 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2124 newSVpvs(ATTRSMODULE),
2125 NULL, op_prepend_elem(OP_LIST,
2126 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2127 op_prepend_elem(OP_LIST,
2128 newSVOP(OP_CONST, 0,
2129 newRV(MUTABLE_SV(cv))),
2134 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2138 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2140 PERL_ARGS_ASSERT_MY_KID;
2142 if (!o || (PL_parser && PL_parser->error_count))
2146 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2147 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2151 if (type == OP_LIST) {
2153 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2154 my_kid(kid, attrs, imopsp);
2155 } else if (type == OP_UNDEF
2161 } else if (type == OP_RV2SV || /* "our" declaration */
2163 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2164 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2165 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2167 PL_parser->in_my == KEY_our
2169 : PL_parser->in_my == KEY_state ? "state" : "my"));
2171 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2172 PL_parser->in_my = FALSE;
2173 PL_parser->in_my_stash = NULL;
2174 apply_attrs(GvSTASH(gv),
2175 (type == OP_RV2SV ? GvSV(gv) :
2176 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2177 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2180 o->op_private |= OPpOUR_INTRO;
2183 else if (type != OP_PADSV &&
2186 type != OP_PUSHMARK)
2188 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2190 PL_parser->in_my == KEY_our
2192 : PL_parser->in_my == KEY_state ? "state" : "my"));
2195 else if (attrs && type != OP_PUSHMARK) {
2198 PL_parser->in_my = FALSE;
2199 PL_parser->in_my_stash = NULL;
2201 /* check for C<my Dog $spot> when deciding package */
2202 stash = PAD_COMPNAME_TYPE(o->op_targ);
2204 stash = PL_curstash;
2205 apply_attrs_my(stash, o, attrs, imopsp);
2207 o->op_flags |= OPf_MOD;
2208 o->op_private |= OPpLVAL_INTRO;
2210 o->op_private |= OPpPAD_STATE;
2215 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2219 int maybe_scalar = 0;
2221 PERL_ARGS_ASSERT_MY_ATTRS;
2223 /* [perl #17376]: this appears to be premature, and results in code such as
2224 C< our(%x); > executing in list mode rather than void mode */
2226 if (o->op_flags & OPf_PARENS)
2236 o = my_kid(o, attrs, &rops);
2238 if (maybe_scalar && o->op_type == OP_PADSV) {
2239 o = scalar(op_append_list(OP_LIST, rops, o));
2240 o->op_private |= OPpLVAL_INTRO;
2243 o = op_append_list(OP_LIST, o, rops);
2245 PL_parser->in_my = FALSE;
2246 PL_parser->in_my_stash = NULL;
2251 Perl_sawparens(pTHX_ OP *o)
2253 PERL_UNUSED_CONTEXT;
2255 o->op_flags |= OPf_PARENS;
2260 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2264 const OPCODE ltype = left->op_type;
2265 const OPCODE rtype = right->op_type;
2267 PERL_ARGS_ASSERT_BIND_MATCH;
2269 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2270 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2272 const char * const desc
2274 rtype == OP_SUBST || rtype == OP_TRANS
2275 || rtype == OP_TRANSR
2277 ? (int)rtype : OP_MATCH];
2278 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2279 ? "@array" : "%hash");
2280 Perl_warner(aTHX_ packWARN(WARN_MISC),
2281 "Applying %s to %s will act on scalar(%s)",
2282 desc, sample, sample);
2285 if (rtype == OP_CONST &&
2286 cSVOPx(right)->op_private & OPpCONST_BARE &&
2287 cSVOPx(right)->op_private & OPpCONST_STRICT)
2289 no_bareword_allowed(right);
2292 /* !~ doesn't make sense with /r, so error on it for now */
2293 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2295 yyerror("Using !~ with s///r doesn't make sense");
2296 if (rtype == OP_TRANSR && type == OP_NOT)
2297 yyerror("Using !~ with tr///r doesn't make sense");
2299 ismatchop = (rtype == OP_MATCH ||
2300 rtype == OP_SUBST ||
2301 rtype == OP_TRANS || rtype == OP_TRANSR)
2302 && !(right->op_flags & OPf_SPECIAL);
2303 if (ismatchop && right->op_private & OPpTARGET_MY) {
2305 right->op_private &= ~OPpTARGET_MY;
2307 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2310 right->op_flags |= OPf_STACKED;
2311 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2312 ! (rtype == OP_TRANS &&
2313 right->op_private & OPpTRANS_IDENTICAL) &&
2314 ! (rtype == OP_SUBST &&
2315 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2316 newleft = op_lvalue(left, rtype);
2319 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2320 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2322 o = op_prepend_elem(rtype, scalar(newleft), right);
2324 return newUNOP(OP_NOT, 0, scalar(o));
2328 return bind_match(type, left,
2329 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2333 Perl_invert(pTHX_ OP *o)
2337 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2341 =for apidoc Amx|OP *|op_scope|OP *o
2343 Wraps up an op tree with some additional ops so that at runtime a dynamic
2344 scope will be created. The original ops run in the new dynamic scope,
2345 and then, provided that they exit normally, the scope will be unwound.
2346 The additional ops used to create and unwind the dynamic scope will
2347 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2348 instead if the ops are simple enough to not need the full dynamic scope
2355 Perl_op_scope(pTHX_ OP *o)
2359 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2360 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2361 o->op_type = OP_LEAVE;
2362 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2364 else if (o->op_type == OP_LINESEQ) {
2366 o->op_type = OP_SCOPE;
2367 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2368 kid = ((LISTOP*)o)->op_first;
2369 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2372 /* The following deals with things like 'do {1 for 1}' */
2373 kid = kid->op_sibling;
2375 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2380 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2386 Perl_block_start(pTHX_ int full)
2389 const int retval = PL_savestack_ix;
2391 pad_block_start(full);
2393 PL_hints &= ~HINT_BLOCK_SCOPE;
2394 SAVECOMPILEWARNINGS();
2395 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2397 CALL_BLOCK_HOOKS(bhk_start, full);
2403 Perl_block_end(pTHX_ I32 floor, OP *seq)
2406 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2407 OP* retval = scalarseq(seq);
2409 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2412 CopHINTS_set(&PL_compiling, PL_hints);
2414 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2417 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2423 =head1 Compile-time scope hooks
2425 =for apidoc Aox||blockhook_register
2427 Register a set of hooks to be called when the Perl lexical scope changes
2428 at compile time. See L<perlguts/"Compile-time scope hooks">.
2434 Perl_blockhook_register(pTHX_ BHK *hk)
2436 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2438 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2445 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2446 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2447 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2450 OP * const o = newOP(OP_PADSV, 0);
2451 o->op_targ = offset;
2457 Perl_newPROG(pTHX_ OP *o)
2461 PERL_ARGS_ASSERT_NEWPROG;
2466 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2467 ((PL_in_eval & EVAL_KEEPERR)
2468 ? OPf_SPECIAL : 0), o);
2469 /* don't use LINKLIST, since PL_eval_root might indirect through
2470 * a rather expensive function call and LINKLIST evaluates its
2471 * argument more than once */
2472 PL_eval_start = op_linklist(PL_eval_root);
2473 PL_eval_root->op_private |= OPpREFCOUNTED;
2474 OpREFCNT_set(PL_eval_root, 1);
2475 PL_eval_root->op_next = 0;
2476 CALL_PEEP(PL_eval_start);
2479 if (o->op_type == OP_STUB) {
2480 PL_comppad_name = 0;
2482 S_op_destroy(aTHX_ o);
2485 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2486 PL_curcop = &PL_compiling;
2487 PL_main_start = LINKLIST(PL_main_root);
2488 PL_main_root->op_private |= OPpREFCOUNTED;
2489 OpREFCNT_set(PL_main_root, 1);
2490 PL_main_root->op_next = 0;
2491 CALL_PEEP(PL_main_start);
2494 /* Register with debugger */
2496 CV * const cv = get_cvs("DB::postponed", 0);
2500 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2502 call_sv(MUTABLE_SV(cv), G_DISCARD);
2509 Perl_localize(pTHX_ OP *o, I32 lex)
2513 PERL_ARGS_ASSERT_LOCALIZE;
2515 if (o->op_flags & OPf_PARENS)
2516 /* [perl #17376]: this appears to be premature, and results in code such as
2517 C< our(%x); > executing in list mode rather than void mode */
2524 if ( PL_parser->bufptr > PL_parser->oldbufptr
2525 && PL_parser->bufptr[-1] == ','
2526 && ckWARN(WARN_PARENTHESIS))
2528 char *s = PL_parser->bufptr;
2531 /* some heuristics to detect a potential error */
2532 while (*s && (strchr(", \t\n", *s)))
2536 if (*s && strchr("@$%*", *s) && *++s
2537 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2540 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2542 while (*s && (strchr(", \t\n", *s)))
2548 if (sigil && (*s == ';' || *s == '=')) {
2549 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2550 "Parentheses missing around \"%s\" list",
2552 ? (PL_parser->in_my == KEY_our
2554 : PL_parser->in_my == KEY_state
2564 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2565 PL_parser->in_my = FALSE;
2566 PL_parser->in_my_stash = NULL;
2571 Perl_jmaybe(pTHX_ OP *o)
2573 PERL_ARGS_ASSERT_JMAYBE;
2575 if (o->op_type == OP_LIST) {
2577 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2578 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2584 S_fold_constants(pTHX_ register OP *o)
2587 register OP * VOL curop;
2589 VOL I32 type = o->op_type;
2594 SV * const oldwarnhook = PL_warnhook;
2595 SV * const olddiehook = PL_diehook;
2599 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2601 if (PL_opargs[type] & OA_RETSCALAR)
2603 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2604 o->op_targ = pad_alloc(type, SVs_PADTMP);
2606 /* integerize op, unless it happens to be C<-foo>.
2607 * XXX should pp_i_negate() do magic string negation instead? */
2608 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2609 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2610 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2612 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2615 if (!(PL_opargs[type] & OA_FOLDCONST))
2620 /* XXX might want a ck_negate() for this */
2621 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2633 /* XXX what about the numeric ops? */
2634 if (PL_hints & HINT_LOCALE)
2639 if (PL_parser && PL_parser->error_count)
2640 goto nope; /* Don't try to run w/ errors */
2642 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2643 const OPCODE type = curop->op_type;
2644 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2646 type != OP_SCALAR &&
2648 type != OP_PUSHMARK)
2654 curop = LINKLIST(o);
2655 old_next = o->op_next;
2659 oldscope = PL_scopestack_ix;
2660 create_eval_scope(G_FAKINGEVAL);
2662 /* Verify that we don't need to save it: */
2663 assert(PL_curcop == &PL_compiling);
2664 StructCopy(&PL_compiling, ¬_compiling, COP);
2665 PL_curcop = ¬_compiling;
2666 /* The above ensures that we run with all the correct hints of the
2667 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2668 assert(IN_PERL_RUNTIME);
2669 PL_warnhook = PERL_WARNHOOK_FATAL;
2676 sv = *(PL_stack_sp--);
2677 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2679 /* Can't simply swipe the SV from the pad, because that relies on
2680 the op being freed "real soon now". Under MAD, this doesn't
2681 happen (see the #ifdef below). */
2684 pad_swipe(o->op_targ, FALSE);
2687 else if (SvTEMP(sv)) { /* grab mortal temp? */
2688 SvREFCNT_inc_simple_void(sv);
2693 /* Something tried to die. Abandon constant folding. */
2694 /* Pretend the error never happened. */
2696 o->op_next = old_next;
2700 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2701 PL_warnhook = oldwarnhook;
2702 PL_diehook = olddiehook;
2703 /* XXX note that this croak may fail as we've already blown away
2704 * the stack - eg any nested evals */
2705 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2708 PL_warnhook = oldwarnhook;
2709 PL_diehook = olddiehook;
2710 PL_curcop = &PL_compiling;
2712 if (PL_scopestack_ix > oldscope)
2713 delete_eval_scope();
2722 if (type == OP_RV2GV)
2723 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2725 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2726 op_getmad(o,newop,'f');
2734 S_gen_constant_list(pTHX_ register OP *o)
2738 const I32 oldtmps_floor = PL_tmps_floor;
2741 if (PL_parser && PL_parser->error_count)
2742 return o; /* Don't attempt to run with errors */
2744 PL_op = curop = LINKLIST(o);
2747 Perl_pp_pushmark(aTHX);
2750 assert (!(curop->op_flags & OPf_SPECIAL));
2751 assert(curop->op_type == OP_RANGE);
2752 Perl_pp_anonlist(aTHX);
2753 PL_tmps_floor = oldtmps_floor;
2755 o->op_type = OP_RV2AV;
2756 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2757 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2758 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2759 o->op_opt = 0; /* needs to be revisited in rpeep() */
2760 curop = ((UNOP*)o)->op_first;
2761 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2763 op_getmad(curop,o,'O');
2772 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2775 if (!o || o->op_type != OP_LIST)
2776 o = newLISTOP(OP_LIST, 0, o, NULL);
2778 o->op_flags &= ~OPf_WANT;
2780 if (!(PL_opargs[type] & OA_MARK))
2781 op_null(cLISTOPo->op_first);
2783 o->op_type = (OPCODE)type;
2784 o->op_ppaddr = PL_ppaddr[type];
2785 o->op_flags |= flags;
2787 o = CHECKOP(type, o);
2788 if (o->op_type != (unsigned)type)
2791 return fold_constants(o);
2795 =head1 Optree Manipulation Functions
2798 /* List constructors */
2801 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2803 Append an item to the list of ops contained directly within a list-type
2804 op, returning the lengthened list. I<first> is the list-type op,
2805 and I<last> is the op to append to the list. I<optype> specifies the
2806 intended opcode for the list. If I<first> is not already a list of the
2807 right type, it will be upgraded into one. If either I<first> or I<last>
2808 is null, the other is returned unchanged.
2814 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2822 if (first->op_type != (unsigned)type
2823 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2825 return newLISTOP(type, 0, first, last);
2828 if (first->op_flags & OPf_KIDS)
2829 ((LISTOP*)first)->op_last->op_sibling = last;
2831 first->op_flags |= OPf_KIDS;
2832 ((LISTOP*)first)->op_first = last;
2834 ((LISTOP*)first)->op_last = last;
2839 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2841 Concatenate the lists of ops contained directly within two list-type ops,
2842 returning the combined list. I<first> and I<last> are the list-type ops
2843 to concatenate. I<optype> specifies the intended opcode for the list.
2844 If either I<first> or I<last> is not already a list of the right type,
2845 it will be upgraded into one. If either I<first> or I<last> is null,
2846 the other is returned unchanged.
2852 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2860 if (first->op_type != (unsigned)type)
2861 return op_prepend_elem(type, first, last);
2863 if (last->op_type != (unsigned)type)
2864 return op_append_elem(type, first, last);
2866 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2867 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2868 first->op_flags |= (last->op_flags & OPf_KIDS);
2871 if (((LISTOP*)last)->op_first && first->op_madprop) {
2872 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2874 while (mp->mad_next)
2876 mp->mad_next = first->op_madprop;
2879 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2882 first->op_madprop = last->op_madprop;
2883 last->op_madprop = 0;
2886 S_op_destroy(aTHX_ last);
2892 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2894 Prepend an item to the list of ops contained directly within a list-type
2895 op, returning the lengthened list. I<first> is the op to prepend to the
2896 list, and I<last> is the list-type op. I<optype> specifies the intended
2897 opcode for the list. If I<last> is not already a list of the right type,
2898 it will be upgraded into one. If either I<first> or I<last> is null,
2899 the other is returned unchanged.
2905 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2913 if (last->op_type == (unsigned)type) {
2914 if (type == OP_LIST) { /* already a PUSHMARK there */
2915 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2916 ((LISTOP*)last)->op_first->op_sibling = first;
2917 if (!(first->op_flags & OPf_PARENS))
2918 last->op_flags &= ~OPf_PARENS;
2921 if (!(last->op_flags & OPf_KIDS)) {
2922 ((LISTOP*)last)->op_last = first;
2923 last->op_flags |= OPf_KIDS;
2925 first->op_sibling = ((LISTOP*)last)->op_first;
2926 ((LISTOP*)last)->op_first = first;
2928 last->op_flags |= OPf_KIDS;
2932 return newLISTOP(type, 0, first, last);
2940 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2943 Newxz(tk, 1, TOKEN);
2944 tk->tk_type = (OPCODE)optype;
2945 tk->tk_type = 12345;
2947 tk->tk_mad = madprop;
2952 Perl_token_free(pTHX_ TOKEN* tk)
2954 PERL_ARGS_ASSERT_TOKEN_FREE;
2956 if (tk->tk_type != 12345)
2958 mad_free(tk->tk_mad);
2963 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2968 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2970 if (tk->tk_type != 12345) {
2971 Perl_warner(aTHX_ packWARN(WARN_MISC),
2972 "Invalid TOKEN object ignored");
2979 /* faked up qw list? */
2981 tm->mad_type == MAD_SV &&
2982 SvPVX((SV *)tm->mad_val)[0] == 'q')
2989 /* pretend constant fold didn't happen? */
2990 if (mp->mad_key == 'f' &&
2991 (o->op_type == OP_CONST ||
2992 o->op_type == OP_GV) )
2994 token_getmad(tk,(OP*)mp->mad_val,slot);
3008 if (mp->mad_key == 'X')
3009 mp->mad_key = slot; /* just change the first one */
3019 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3028 /* pretend constant fold didn't happen? */
3029 if (mp->mad_key == 'f' &&
3030 (o->op_type == OP_CONST ||
3031 o->op_type == OP_GV) )
3033 op_getmad(from,(OP*)mp->mad_val,slot);
3040 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3043 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3049 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3058 /* pretend constant fold didn't happen? */
3059 if (mp->mad_key == 'f' &&
3060 (o->op_type == OP_CONST ||
3061 o->op_type == OP_GV) )
3063 op_getmad(from,(OP*)mp->mad_val,slot);
3070 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3073 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3077 PerlIO_printf(PerlIO_stderr(),
3078 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3084 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3102 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3106 addmad(tm, &(o->op_madprop), slot);
3110 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3131 Perl_newMADsv(pTHX_ char key, SV* sv)
3133 PERL_ARGS_ASSERT_NEWMADSV;
3135 return newMADPROP(key, MAD_SV, sv, 0);
3139 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3141 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3144 mp->mad_vlen = vlen;
3145 mp->mad_type = type;
3147 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3152 Perl_mad_free(pTHX_ MADPROP* mp)
3154 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3158 mad_free(mp->mad_next);
3159 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3160 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3161 switch (mp->mad_type) {
3165 Safefree((char*)mp->mad_val);
3168 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3169 op_free((OP*)mp->mad_val);
3172 sv_free(MUTABLE_SV(mp->mad_val));
3175 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3178 PerlMemShared_free(mp);
3184 =head1 Optree construction
3186 =for apidoc Am|OP *|newNULLLIST
3188 Constructs, checks, and returns a new C<stub> op, which represents an
3189 empty list expression.
3195 Perl_newNULLLIST(pTHX)
3197 return newOP(OP_STUB, 0);
3201 S_force_list(pTHX_ OP *o)
3203 if (!o || o->op_type != OP_LIST)
3204 o = newLISTOP(OP_LIST, 0, o, NULL);
3210 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3212 Constructs, checks, and returns an op of any list type. I<type> is
3213 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3214 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3215 supply up to two ops to be direct children of the list op; they are
3216 consumed by this function and become part of the constructed op tree.
3222 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3227 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3229 NewOp(1101, listop, 1, LISTOP);
3231 listop->op_type = (OPCODE)type;
3232 listop->op_ppaddr = PL_ppaddr[type];
3235 listop->op_flags = (U8)flags;
3239 else if (!first && last)
3242 first->op_sibling = last;
3243 listop->op_first = first;
3244 listop->op_last = last;
3245 if (type == OP_LIST) {
3246 OP* const pushop = newOP(OP_PUSHMARK, 0);
3247 pushop->op_sibling = first;
3248 listop->op_first = pushop;
3249 listop->op_flags |= OPf_KIDS;
3251 listop->op_last = pushop;
3254 return CHECKOP(type, listop);
3258 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3260 Constructs, checks, and returns an op of any base type (any type that
3261 has no extra fields). I<type> is the opcode. I<flags> gives the
3262 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3269 Perl_newOP(pTHX_ I32 type, I32 flags)
3274 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3275 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3276 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3277 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3279 NewOp(1101, o, 1, OP);
3280 o->op_type = (OPCODE)type;
3281 o->op_ppaddr = PL_ppaddr[type];
3282 o->op_flags = (U8)flags;
3284 o->op_latefreed = 0;
3288 o->op_private = (U8)(0 | (flags >> 8));
3289 if (PL_opargs[type] & OA_RETSCALAR)
3291 if (PL_opargs[type] & OA_TARGET)
3292 o->op_targ = pad_alloc(type, SVs_PADTMP);
3293 return CHECKOP(type, o);
3297 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3299 Constructs, checks, and returns an op of any unary type. I<type> is
3300 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3301 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3302 bits, the eight bits of C<op_private>, except that the bit with value 1
3303 is automatically set. I<first> supplies an optional op to be the direct
3304 child of the unary op; it is consumed by this function and become part
3305 of the constructed op tree.
3311 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3316 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3317 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3318 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3319 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3320 || type == OP_SASSIGN
3321 || type == OP_ENTERTRY
3322 || type == OP_NULL );
3325 first = newOP(OP_STUB, 0);
3326 if (PL_opargs[type] & OA_MARK)
3327 first = force_list(first);
3329 NewOp(1101, unop, 1, UNOP);
3330 unop->op_type = (OPCODE)type;
3331 unop->op_ppaddr = PL_ppaddr[type];
3332 unop->op_first = first;
3333 unop->op_flags = (U8)(flags | OPf_KIDS);
3334 unop->op_private = (U8)(1 | (flags >> 8));
3335 unop = (UNOP*) CHECKOP(type, unop);
3339 return fold_constants((OP *) unop);
3343 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3345 Constructs, checks, and returns an op of any binary type. I<type>
3346 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3347 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3348 the eight bits of C<op_private>, except that the bit with value 1 or
3349 2 is automatically set as required. I<first> and I<last> supply up to
3350 two ops to be the direct children of the binary op; they are consumed
3351 by this function and become part of the constructed op tree.
3357 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3362 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3363 || type == OP_SASSIGN || type == OP_NULL );
3365 NewOp(1101, binop, 1, BINOP);
3368 first = newOP(OP_NULL, 0);
3370 binop->op_type = (OPCODE)type;
3371 binop->op_ppaddr = PL_ppaddr[type];
3372 binop->op_first = first;
3373 binop->op_flags = (U8)(flags | OPf_KIDS);
3376 binop->op_private = (U8)(1 | (flags >> 8));
3379 binop->op_private = (U8)(2 | (flags >> 8));
3380 first->op_sibling = last;
3383 binop = (BINOP*)CHECKOP(type, binop);
3384 if (binop->op_next || binop->op_type != (OPCODE)type)
3387 binop->op_last = binop->op_first->op_sibling;
3389 return fold_constants((OP *)binop);
3392 static int uvcompare(const void *a, const void *b)
3393 __attribute__nonnull__(1)
3394 __attribute__nonnull__(2)
3395 __attribute__pure__;
3396 static int uvcompare(const void *a, const void *b)
3398 if (*((const UV *)a) < (*(const UV *)b))
3400 if (*((const UV *)a) > (*(const UV *)b))
3402 if (*((const UV *)a+1) < (*(const UV *)b+1))
3404 if (*((const UV *)a+1) > (*(const UV *)b+1))
3410 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3413 SV * const tstr = ((SVOP*)expr)->op_sv;
3416 (repl->op_type == OP_NULL)
3417 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3419 ((SVOP*)repl)->op_sv;
3422 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3423 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3427 register short *tbl;
3429 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3430 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3431 I32 del = o->op_private & OPpTRANS_DELETE;
3434 PERL_ARGS_ASSERT_PMTRANS;
3436 PL_hints |= HINT_BLOCK_SCOPE;
3439 o->op_private |= OPpTRANS_FROM_UTF;
3442 o->op_private |= OPpTRANS_TO_UTF;
3444 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3445 SV* const listsv = newSVpvs("# comment\n");
3447 const U8* tend = t + tlen;
3448 const U8* rend = r + rlen;
3462 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3463 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3466 const U32 flags = UTF8_ALLOW_DEFAULT;
3470 t = tsave = bytes_to_utf8(t, &len);
3473 if (!to_utf && rlen) {
3475 r = rsave = bytes_to_utf8(r, &len);
3479 /* There are several snags with this code on EBCDIC:
3480 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3481 2. scan_const() in toke.c has encoded chars in native encoding which makes
3482 ranges at least in EBCDIC 0..255 range the bottom odd.
3486 U8 tmpbuf[UTF8_MAXBYTES+1];
3489 Newx(cp, 2*tlen, UV);
3491 transv = newSVpvs("");
3493 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3495 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3497 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3501 cp[2*i+1] = cp[2*i];
3505 qsort(cp, i, 2*sizeof(UV), uvcompare);
3506 for (j = 0; j < i; j++) {
3508 diff = val - nextmin;
3510 t = uvuni_to_utf8(tmpbuf,nextmin);
3511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3513 U8 range_mark = UTF_TO_NATIVE(0xff);
3514 t = uvuni_to_utf8(tmpbuf, val - 1);
3515 sv_catpvn(transv, (char *)&range_mark, 1);
3516 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3523 t = uvuni_to_utf8(tmpbuf,nextmin);
3524 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3526 U8 range_mark = UTF_TO_NATIVE(0xff);
3527 sv_catpvn(transv, (char *)&range_mark, 1);
3529 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3530 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3531 t = (const U8*)SvPVX_const(transv);
3532 tlen = SvCUR(transv);
3536 else if (!rlen && !del) {
3537 r = t; rlen = tlen; rend = tend;
3540 if ((!rlen && !del) || t == r ||
3541 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3543 o->op_private |= OPpTRANS_IDENTICAL;
3547 while (t < tend || tfirst <= tlast) {
3548 /* see if we need more "t" chars */
3549 if (tfirst > tlast) {
3550 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3552 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3554 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3561 /* now see if we need more "r" chars */
3562 if (rfirst > rlast) {
3564 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3566 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3568 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3577 rfirst = rlast = 0xffffffff;
3581 /* now see which range will peter our first, if either. */
3582 tdiff = tlast - tfirst;
3583 rdiff = rlast - rfirst;
3590 if (rfirst == 0xffffffff) {
3591 diff = tdiff; /* oops, pretend rdiff is infinite */
3593 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3594 (long)tfirst, (long)tlast);
3596 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3600 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3601 (long)tfirst, (long)(tfirst + diff),
3604 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3605 (long)tfirst, (long)rfirst);
3607 if (rfirst + diff > max)
3608 max = rfirst + diff;
3610 grows = (tfirst < rfirst &&
3611 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3623 else if (max > 0xff)
3628 PerlMemShared_free(cPVOPo->op_pv);
3629 cPVOPo->op_pv = NULL;
3631 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3633 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3634 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3635 PAD_SETSV(cPADOPo->op_padix, swash);
3637 SvREADONLY_on(swash);
3639 cSVOPo->op_sv = swash;
3641 SvREFCNT_dec(listsv);
3642 SvREFCNT_dec(transv);
3644 if (!del && havefinal && rlen)
3645 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3646 newSVuv((UV)final), 0);
3649 o->op_private |= OPpTRANS_GROWS;
3655 op_getmad(expr,o,'e');
3656 op_getmad(repl,o,'r');
3664 tbl = (short*)cPVOPo->op_pv;
3666 Zero(tbl, 256, short);
3667 for (i = 0; i < (I32)tlen; i++)
3669 for (i = 0, j = 0; i < 256; i++) {
3671 if (j >= (I32)rlen) {
3680 if (i < 128 && r[j] >= 128)
3690 o->op_private |= OPpTRANS_IDENTICAL;
3692 else if (j >= (I32)rlen)
3697 PerlMemShared_realloc(tbl,
3698 (0x101+rlen-j) * sizeof(short));
3699 cPVOPo->op_pv = (char*)tbl;
3701 tbl[0x100] = (short)(rlen - j);
3702 for (i=0; i < (I32)rlen - j; i++)
3703 tbl[0x101+i] = r[j+i];
3707 if (!rlen && !del) {
3710 o->op_private |= OPpTRANS_IDENTICAL;
3712 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3713 o->op_private |= OPpTRANS_IDENTICAL;
3715 for (i = 0; i < 256; i++)
3717 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3718 if (j >= (I32)rlen) {
3720 if (tbl[t[i]] == -1)
3726 if (tbl[t[i]] == -1) {
3727 if (t[i] < 128 && r[j] >= 128)
3734 if(del && rlen == tlen) {
3735 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3736 } else if(rlen > tlen) {
3737 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3741 o->op_private |= OPpTRANS_GROWS;
3743 op_getmad(expr,o,'e');
3744 op_getmad(repl,o,'r');
3754 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3756 Constructs, checks, and returns an op of any pattern matching type.
3757 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3758 and, shifted up eight bits, the eight bits of C<op_private>.
3764 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3769 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3771 NewOp(1101, pmop, 1, PMOP);
3772 pmop->op_type = (OPCODE)type;
3773 pmop->op_ppaddr = PL_ppaddr[type];
3774 pmop->op_flags = (U8)flags;
3775 pmop->op_private = (U8)(0 | (flags >> 8));
3777 if (PL_hints & HINT_RE_TAINT)
3778 pmop->op_pmflags |= PMf_RETAINT;
3779 if (PL_hints & HINT_LOCALE) {
3780 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
3782 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3783 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
3785 if (PL_hints & HINT_RE_FLAGS) {
3786 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3787 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3789 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3790 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3791 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
3793 if (reflags && SvOK(reflags)) {
3794 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
3800 assert(SvPOK(PL_regex_pad[0]));
3801 if (SvCUR(PL_regex_pad[0])) {
3802 /* Pop off the "packed" IV from the end. */
3803 SV *const repointer_list = PL_regex_pad[0];
3804 const char *p = SvEND(repointer_list) - sizeof(IV);
3805 const IV offset = *((IV*)p);
3807 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3809 SvEND_set(repointer_list, p);
3811 pmop->op_pmoffset = offset;
3812 /* This slot should be free, so assert this: */
3813 assert(PL_regex_pad[offset] == &PL_sv_undef);
3815 SV * const repointer = &PL_sv_undef;
3816 av_push(PL_regex_padav, repointer);
3817 pmop->op_pmoffset = av_len(PL_regex_padav);
3818 PL_regex_pad = AvARRAY(PL_regex_padav);
3822 return CHECKOP(type, pmop);
3825 /* Given some sort of match op o, and an expression expr containing a
3826 * pattern, either compile expr into a regex and attach it to o (if it's
3827 * constant), or convert expr into a runtime regcomp op sequence (if it's
3830 * isreg indicates that the pattern is part of a regex construct, eg
3831 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3832 * split "pattern", which aren't. In the former case, expr will be a list
3833 * if the pattern contains more than one term (eg /a$b/) or if it contains
3834 * a replacement, ie s/// or tr///.
3838 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3843 I32 repl_has_vars = 0;
3847 PERL_ARGS_ASSERT_PMRUNTIME;
3850 o->op_type == OP_SUBST
3851 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3853 /* last element in list is the replacement; pop it */
3855 repl = cLISTOPx(expr)->op_last;
3856 kid = cLISTOPx(expr)->op_first;
3857 while (kid->op_sibling != repl)
3858 kid = kid->op_sibling;
3859 kid->op_sibling = NULL;
3860 cLISTOPx(expr)->op_last = kid;
3863 if (isreg && expr->op_type == OP_LIST &&
3864 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3866 /* convert single element list to element */
3867 OP* const oe = expr;
3868 expr = cLISTOPx(oe)->op_first->op_sibling;
3869 cLISTOPx(oe)->op_first->op_sibling = NULL;
3870 cLISTOPx(oe)->op_last = NULL;
3874 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3875 return pmtrans(o, expr, repl);
3878 reglist = isreg && expr->op_type == OP_LIST;
3882 PL_hints |= HINT_BLOCK_SCOPE;
3885 if (expr->op_type == OP_CONST) {
3886 SV *pat = ((SVOP*)expr)->op_sv;
3887 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3889 if (o->op_flags & OPf_SPECIAL)
3890 pm_flags |= RXf_SPLIT;
3893 assert (SvUTF8(pat));
3894 } else if (SvUTF8(pat)) {
3895 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3896 trapped in use 'bytes'? */
3897 /* Make a copy of the octet sequence, but without the flag on, as
3898 the compiler now honours the SvUTF8 flag on pat. */
3900 const char *const p = SvPV(pat, len);
3901 pat = newSVpvn_flags(p, len, SVs_TEMP);
3904 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3907 op_getmad(expr,(OP*)pm,'e');
3913 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3914 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3916 : OP_REGCMAYBE),0,expr);
3918 NewOp(1101, rcop, 1, LOGOP);
3919 rcop->op_type = OP_REGCOMP;
3920 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3921 rcop->op_first = scalar(expr);
3922 rcop->op_flags |= OPf_KIDS
3923 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3924 | (reglist ? OPf_STACKED : 0);
3925 rcop->op_private = 1;
3928 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3930 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3931 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
3933 /* establish postfix order */
3934 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3936 rcop->op_next = expr;
3937 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3940 rcop->op_next = LINKLIST(expr);
3941 expr->op_next = (OP*)rcop;
3944 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3949 if (pm->op_pmflags & PMf_EVAL) {
3951 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3952 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3954 else if (repl->op_type == OP_CONST)
3958 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3959 if (curop->op_type == OP_SCOPE
3960 || curop->op_type == OP_LEAVE
3961 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3962 if (curop->op_type == OP_GV) {
3963 GV * const gv = cGVOPx_gv(curop);
3965 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3968 else if (curop->op_type == OP_RV2CV)
3970 else if (curop->op_type == OP_RV2SV ||
3971 curop->op_type == OP_RV2AV ||
3972 curop->op_type == OP_RV2HV ||
3973 curop->op_type == OP_RV2GV) {
3974 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3977 else if (curop->op_type == OP_PADSV ||
3978 curop->op_type == OP_PADAV ||
3979 curop->op_type == OP_PADHV ||
3980 curop->op_type == OP_PADANY)
3984 else if (curop->op_type == OP_PUSHRE)
3985 NOOP; /* Okay here, dangerous in newASSIGNOP */
3995 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3997 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3998 op_prepend_elem(o->op_type, scalar(repl), o);
4001 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4002 pm->op_pmflags |= PMf_MAYBE_CONST;
4004 NewOp(1101, rcop, 1, LOGOP);
4005 rcop->op_type = OP_SUBSTCONT;
4006 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4007 rcop->op_first = scalar(repl);
4008 rcop->op_flags |= OPf_KIDS;
4009 rcop->op_private = 1;
4012 /* establish postfix order */
4013 rcop->op_next = LINKLIST(repl);
4014 repl->op_next = (OP*)rcop;
4016 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4017 assert(!(pm->op_pmflags & PMf_ONCE));
4018 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4027 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4029 Constructs, checks, and returns an op of any type that involves an
4030 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4031 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4032 takes ownership of one reference to it.
4038 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4043 PERL_ARGS_ASSERT_NEWSVOP;
4045 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4046 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4047 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4049 NewOp(1101, svop, 1, SVOP);
4050 svop->op_type = (OPCODE)type;
4051 svop->op_ppaddr = PL_ppaddr[type];
4053 svop->op_next = (OP*)svop;
4054 svop->op_flags = (U8)flags;
4055 if (PL_opargs[type] & OA_RETSCALAR)
4057 if (PL_opargs[type] & OA_TARGET)
4058 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4059 return CHECKOP(type, svop);
4065 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4067 Constructs, checks, and returns an op of any type that involves a
4068 reference to a pad element. I<type> is the opcode. I<flags> gives the
4069 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4070 is populated with I<sv>; this function takes ownership of one reference
4073 This function only exists if Perl has been compiled to use ithreads.
4079 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4084 PERL_ARGS_ASSERT_NEWPADOP;
4086 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4087 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4088 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4090 NewOp(1101, padop, 1, PADOP);
4091 padop->op_type = (OPCODE)type;
4092 padop->op_ppaddr = PL_ppaddr[type];
4093 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4094 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4095 PAD_SETSV(padop->op_padix, sv);
4098 padop->op_next = (OP*)padop;
4099 padop->op_flags = (U8)flags;
4100 if (PL_opargs[type] & OA_RETSCALAR)
4102 if (PL_opargs[type] & OA_TARGET)
4103 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4104 return CHECKOP(type, padop);
4107 #endif /* !USE_ITHREADS */
4110 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4112 Constructs, checks, and returns an op of any type that involves an
4113 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4114 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4115 reference; calling this function does not transfer ownership of any
4122 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4126 PERL_ARGS_ASSERT_NEWGVOP;
4130 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4132 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4137 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4139 Constructs, checks, and returns an op of any type that involves an
4140 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4141 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4142 must have been allocated using L</PerlMemShared_malloc>; the memory will
4143 be freed when the op is destroyed.
4149 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4154 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4155 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4157 NewOp(1101, pvop, 1, PVOP);
4158 pvop->op_type = (OPCODE)type;
4159 pvop->op_ppaddr = PL_ppaddr[type];
4161 pvop->op_next = (OP*)pvop;
4162 pvop->op_flags = (U8)flags;
4163 if (PL_opargs[type] & OA_RETSCALAR)
4165 if (PL_opargs[type] & OA_TARGET)
4166 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4167 return CHECKOP(type, pvop);
4175 Perl_package(pTHX_ OP *o)
4178 SV *const sv = cSVOPo->op_sv;
4183 PERL_ARGS_ASSERT_PACKAGE;
4185 save_hptr(&PL_curstash);
4186 save_item(PL_curstname);
4188 PL_curstash = gv_stashsv(sv, GV_ADD);
4190 sv_setsv(PL_curstname, sv);
4192 PL_hints |= HINT_BLOCK_SCOPE;
4193 PL_parser->copline = NOLINE;
4194 PL_parser->expect = XSTATE;
4199 if (!PL_madskills) {
4204 pegop = newOP(OP_NULL,0);
4205 op_getmad(o,pegop,'P');
4211 Perl_package_version( pTHX_ OP *v )
4214 U32 savehints = PL_hints;
4215 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4216 PL_hints &= ~HINT_STRICT_VARS;
4217 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4218 PL_hints = savehints;
4227 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4234 OP *pegop = newOP(OP_NULL,0);
4236 SV *use_version = NULL;
4238 PERL_ARGS_ASSERT_UTILIZE;
4240 if (idop->op_type != OP_CONST)
4241 Perl_croak(aTHX_ "Module name must be constant");
4244 op_getmad(idop,pegop,'U');
4249 SV * const vesv = ((SVOP*)version)->op_sv;
4252 op_getmad(version,pegop,'V');
4253 if (!arg && !SvNIOKp(vesv)) {
4260 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4261 Perl_croak(aTHX_ "Version number must be a constant number");
4263 /* Make copy of idop so we don't free it twice */
4264 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4266 /* Fake up a method call to VERSION */
4267 meth = newSVpvs_share("VERSION");
4268 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4269 op_append_elem(OP_LIST,
4270 op_prepend_elem(OP_LIST, pack, list(version)),
4271 newSVOP(OP_METHOD_NAMED, 0, meth)));
4275 /* Fake up an import/unimport */
4276 if (arg && arg->op_type == OP_STUB) {
4278 op_getmad(arg,pegop,'S');
4279 imop = arg; /* no import on explicit () */
4281 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4282 imop = NULL; /* use 5.0; */
4284 use_version = ((SVOP*)idop)->op_sv;
4286 idop->op_private |= OPpCONST_NOVER;
4292 op_getmad(arg,pegop,'A');
4294 /* Make copy of idop so we don't free it twice */
4295 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4297 /* Fake up a method call to import/unimport */
4299 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4300 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4301 op_append_elem(OP_LIST,
4302 op_prepend_elem(OP_LIST, pack, list(arg)),
4303 newSVOP(OP_METHOD_NAMED, 0, meth)));
4306 /* Fake up the BEGIN {}, which does its thing immediately. */
4308 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4311 op_append_elem(OP_LINESEQ,
4312 op_append_elem(OP_LINESEQ,
4313 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4314 newSTATEOP(0, NULL, veop)),
4315 newSTATEOP(0, NULL, imop) ));
4318 /* If we request a version >= 5.9.5, load feature.pm with the
4319 * feature bundle that corresponds to the required version. */
4320 use_version = sv_2mortal(new_version(use_version));
4322 if (vcmp(use_version,
4323 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4324 SV *const importsv = vnormal(use_version);
4325 *SvPVX_mutable(importsv) = ':';
4326 ENTER_with_name("load_feature");
4327 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4328 LEAVE_with_name("load_feature");
4330 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4331 if (vcmp(use_version,
4332 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4333 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4337 /* The "did you use incorrect case?" warning used to be here.
4338 * The problem is that on case-insensitive filesystems one
4339 * might get false positives for "use" (and "require"):
4340 * "use Strict" or "require CARP" will work. This causes
4341 * portability problems for the script: in case-strict
4342 * filesystems the script will stop working.
4344 * The "incorrect case" warning checked whether "use Foo"
4345 * imported "Foo" to your namespace, but that is wrong, too:
4346 * there is no requirement nor promise in the language that
4347 * a Foo.pm should or would contain anything in package "Foo".
4349 * There is very little Configure-wise that can be done, either:
4350 * the case-sensitivity of the build filesystem of Perl does not
4351 * help in guessing the case-sensitivity of the runtime environment.
4354 PL_hints |= HINT_BLOCK_SCOPE;
4355 PL_parser->copline = NOLINE;
4356 PL_parser->expect = XSTATE;
4357 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4358 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4362 if (!PL_madskills) {
4363 /* FIXME - don't allocate pegop if !PL_madskills */
4372 =head1 Embedding Functions
4374 =for apidoc load_module
4376 Loads the module whose name is pointed to by the string part of name.
4377 Note that the actual module name, not its filename, should be given.
4378 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4379 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4380 (or 0 for no flags). ver, if specified, provides version semantics
4381 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4382 arguments can be used to specify arguments to the module's import()
4383 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4384 terminated with a final NULL pointer. Note that this list can only
4385 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4386 Otherwise at least a single NULL pointer to designate the default
4387 import list is required.
4392 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4396 PERL_ARGS_ASSERT_LOAD_MODULE;
4398 va_start(args, ver);
4399 vload_module(flags, name, ver, &args);
4403 #ifdef PERL_IMPLICIT_CONTEXT
4405 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4409 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4410 va_start(args, ver);
4411 vload_module(flags, name, ver, &args);
4417 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4421 OP * const modname = newSVOP(OP_CONST, 0, name);
4423 PERL_ARGS_ASSERT_VLOAD_MODULE;
4425 modname->op_private |= OPpCONST_BARE;
4427 veop = newSVOP(OP_CONST, 0, ver);
4431 if (flags & PERL_LOADMOD_NOIMPORT) {
4432 imop = sawparens(newNULLLIST());
4434 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4435 imop = va_arg(*args, OP*);
4440 sv = va_arg(*args, SV*);
4442 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4443 sv = va_arg(*args, SV*);
4447 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4448 * that it has a PL_parser to play with while doing that, and also
4449 * that it doesn't mess with any existing parser, by creating a tmp
4450 * new parser with lex_start(). This won't actually be used for much,
4451 * since pp_require() will create another parser for the real work. */
4454 SAVEVPTR(PL_curcop);
4455 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4456 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4457 veop, modname, imop);
4462 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4468 PERL_ARGS_ASSERT_DOFILE;
4470 if (!force_builtin) {
4471 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4472 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4473 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4474 gv = gvp ? *gvp : NULL;
4478 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4479 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4480 op_append_elem(OP_LIST, term,
4481 scalar(newUNOP(OP_RV2CV, 0,
4482 newGVOP(OP_GV, 0, gv))))));
4485 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4491 =head1 Optree construction
4493 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4495 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4496 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4497 be set automatically, and, shifted up eight bits, the eight bits of
4498 C<op_private>, except that the bit with value 1 or 2 is automatically
4499 set as required. I<listval> and I<subscript> supply the parameters of
4500 the slice; they are consumed by this function and become part of the
4501 constructed op tree.
4507 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4509 return newBINOP(OP_LSLICE, flags,
4510 list(force_list(subscript)),
4511 list(force_list(listval)) );
4515 S_is_list_assignment(pTHX_ register const OP *o)
4523 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4524 o = cUNOPo->op_first;
4526 flags = o->op_flags;
4528 if (type == OP_COND_EXPR) {
4529 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4530 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4535 yyerror("Assignment to both a list and a scalar");
4539 if (type == OP_LIST &&
4540 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4541 o->op_private & OPpLVAL_INTRO)
4544 if (type == OP_LIST || flags & OPf_PARENS ||
4545 type == OP_RV2AV || type == OP_RV2HV ||
4546 type == OP_ASLICE || type == OP_HSLICE)
4549 if (type == OP_PADAV || type == OP_PADHV)
4552 if (type == OP_RV2SV)
4559 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4561 Constructs, checks, and returns an assignment op. I<left> and I<right>
4562 supply the parameters of the assignment; they are consumed by this
4563 function and become part of the constructed op tree.
4565 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4566 a suitable conditional optree is constructed. If I<optype> is the opcode
4567 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4568 performs the binary operation and assigns the result to the left argument.
4569 Either way, if I<optype> is non-zero then I<flags> has no effect.
4571 If I<optype> is zero, then a plain scalar or list assignment is
4572 constructed. Which type of assignment it is is automatically determined.
4573 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4574 will be set automatically, and, shifted up eight bits, the eight bits
4575 of C<op_private>, except that the bit with value 1 or 2 is automatically
4582 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4588 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4589 return newLOGOP(optype, 0,
4590 op_lvalue(scalar(left), optype),
4591 newUNOP(OP_SASSIGN, 0, scalar(right)));
4594 return newBINOP(optype, OPf_STACKED,
4595 op_lvalue(scalar(left), optype), scalar(right));
4599 if (is_list_assignment(left)) {
4600 static const char no_list_state[] = "Initialization of state variables"
4601 " in list context currently forbidden";
4603 bool maybe_common_vars = TRUE;
4606 /* Grandfathering $[ assignment here. Bletch.*/
4607 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4608 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4609 left = op_lvalue(left, OP_AASSIGN);
4612 else if (left->op_type == OP_CONST) {
4613 deprecate("assignment to $[");
4615 /* Result of assignment is always 1 (or we'd be dead already) */
4616 return newSVOP(OP_CONST, 0, newSViv(1));
4618 curop = list(force_list(left));
4619 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4620 o->op_private = (U8)(0 | (flags >> 8));
4622 if ((left->op_type == OP_LIST
4623 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4625 OP* lop = ((LISTOP*)left)->op_first;
4626 maybe_common_vars = FALSE;
4628 if (lop->op_type == OP_PADSV ||
4629 lop->op_type == OP_PADAV ||
4630 lop->op_type == OP_PADHV ||
4631 lop->op_type == OP_PADANY) {
4632 if (!(lop->op_private & OPpLVAL_INTRO))
4633 maybe_common_vars = TRUE;
4635 if (lop->op_private & OPpPAD_STATE) {
4636 if (left->op_private & OPpLVAL_INTRO) {
4637 /* Each variable in state($a, $b, $c) = ... */
4640 /* Each state variable in
4641 (state $a, my $b, our $c, $d, undef) = ... */
4643 yyerror(no_list_state);
4645 /* Each my variable in
4646 (state $a, my $b, our $c, $d, undef) = ... */
4648 } else if (lop->op_type == OP_UNDEF ||
4649 lop->op_type == OP_PUSHMARK) {
4650 /* undef may be interesting in
4651 (state $a, undef, state $c) */
4653 /* Other ops in the list. */
4654 maybe_common_vars = TRUE;
4656 lop = lop->op_sibling;
4659 else if ((left->op_private & OPpLVAL_INTRO)
4660 && ( left->op_type == OP_PADSV
4661 || left->op_type == OP_PADAV
4662 || left->op_type == OP_PADHV
4663 || left->op_type == OP_PADANY))
4665 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4666 if (left->op_private & OPpPAD_STATE) {
4667 /* All single variable list context state assignments, hence
4677 yyerror(no_list_state);
4681 /* PL_generation sorcery:
4682 * an assignment like ($a,$b) = ($c,$d) is easier than
4683 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4684 * To detect whether there are common vars, the global var
4685 * PL_generation is incremented for each assign op we compile.
4686 * Then, while compiling the assign op, we run through all the
4687 * variables on both sides of the assignment, setting a spare slot
4688 * in each of them to PL_generation. If any of them already have
4689 * that value, we know we've got commonality. We could use a
4690 * single bit marker, but then we'd have to make 2 passes, first
4691 * to clear the flag, then to test and set it. To find somewhere
4692 * to store these values, evil chicanery is done with SvUVX().
4695 if (maybe_common_vars) {
4698 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4699 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4700 if (curop->op_type == OP_GV) {
4701 GV *gv = cGVOPx_gv(curop);
4703 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4705 GvASSIGN_GENERATION_set(gv, PL_generation);
4707 else if (curop->op_type == OP_PADSV ||
4708 curop->op_type == OP_PADAV ||
4709 curop->op_type == OP_PADHV ||
4710 curop->op_type == OP_PADANY)
4712 if (PAD_COMPNAME_GEN(curop->op_targ)
4713 == (STRLEN)PL_generation)
4715 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4718 else if (curop->op_type == OP_RV2CV)
4720 else if (curop->op_type == OP_RV2SV ||
4721 curop->op_type == OP_RV2AV ||
4722 curop->op_type == OP_RV2HV ||
4723 curop->op_type == OP_RV2GV) {
4724 if (lastop->op_type != OP_GV) /* funny deref? */
4727 else if (curop->op_type == OP_PUSHRE) {
4729 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4730 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4732 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4734 GvASSIGN_GENERATION_set(gv, PL_generation);
4738 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4741 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4743 GvASSIGN_GENERATION_set(gv, PL_generation);
4753 o->op_private |= OPpASSIGN_COMMON;
4756 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4757 OP* tmpop = ((LISTOP*)right)->op_first;
4758 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4759 PMOP * const pm = (PMOP*)tmpop;
4760 if (left->op_type == OP_RV2AV &&
4761 !(left->op_private & OPpLVAL_INTRO) &&
4762 !(o->op_private & OPpASSIGN_COMMON) )
4764 tmpop = ((UNOP*)left)->op_first;
4765 if (tmpop->op_type == OP_GV
4767 && !pm->op_pmreplrootu.op_pmtargetoff
4769 && !pm->op_pmreplrootu.op_pmtargetgv
4773 pm->op_pmreplrootu.op_pmtargetoff
4774 = cPADOPx(tmpop)->op_padix;
4775 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4777 pm->op_pmreplrootu.op_pmtargetgv
4778 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4779 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4781 pm->op_pmflags |= PMf_ONCE;
4782 tmpop = cUNOPo->op_first; /* to list (nulled) */
4783 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4784 tmpop->op_sibling = NULL; /* don't free split */
4785 right->op_next = tmpop->op_next; /* fix starting loc */
4786 op_free(o); /* blow off assign */
4787 right->op_flags &= ~OPf_WANT;
4788 /* "I don't know and I don't care." */
4793 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4794 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4796 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4797 if (SvIOK(sv) && SvIVX(sv) == 0)
4798 sv_setiv(sv, PL_modcount+1);
4806 right = newOP(OP_UNDEF, 0);
4807 if (right->op_type == OP_READLINE) {
4808 right->op_flags |= OPf_STACKED;
4809 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4813 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4814 o = newBINOP(OP_SASSIGN, flags,
4815 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4819 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4820 deprecate("assignment to $[");
4822 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4823 o->op_private |= OPpCONST_ARYBASE;
4831 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4833 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4834 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4835 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4836 If I<label> is non-null, it supplies the name of a label to attach to
4837 the state op; this function takes ownership of the memory pointed at by
4838 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4841 If I<o> is null, the state op is returned. Otherwise the state op is
4842 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4843 is consumed by this function and becomes part of the returned op tree.
4849 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4852 const U32 seq = intro_my();
4855 NewOp(1101, cop, 1, COP);
4856 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4857 cop->op_type = OP_DBSTATE;
4858 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4861 cop->op_type = OP_NEXTSTATE;
4862 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4864 cop->op_flags = (U8)flags;
4865 CopHINTS_set(cop, PL_hints);
4867 cop->op_private |= NATIVE_HINTS;
4869 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4870 cop->op_next = (OP*)cop;
4873 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4874 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4876 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4877 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4879 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4881 PL_hints |= HINT_BLOCK_SCOPE;
4882 /* It seems that we need to defer freeing this pointer, as other parts
4883 of the grammar end up wanting to copy it after this op has been
4888 if (PL_parser && PL_parser->copline == NOLINE)
4889 CopLINE_set(cop, CopLINE(PL_curcop));
4891 CopLINE_set(cop, PL_parser->copline);
4893 PL_parser->copline = NOLINE;
4896 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4898 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4900 CopSTASH_set(cop, PL_curstash);
4902 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4903 /* this line can have a breakpoint - store the cop in IV */
4904 AV *av = CopFILEAVx(PL_curcop);
4906 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4907 if (svp && *svp != &PL_sv_undef ) {
4908 (void)SvIOK_on(*svp);
4909 SvIV_set(*svp, PTR2IV(cop));
4914 if (flags & OPf_SPECIAL)
4916 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4920 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4922 Constructs, checks, and returns a logical (flow control) op. I<type>
4923 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4924 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4925 the eight bits of C<op_private>, except that the bit with value 1 is
4926 automatically set. I<first> supplies the expression controlling the
4927 flow, and I<other> supplies the side (alternate) chain of ops; they are
4928 consumed by this function and become part of the constructed op tree.
4934 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4938 PERL_ARGS_ASSERT_NEWLOGOP;
4940 return new_logop(type, flags, &first, &other);
4944 S_search_const(pTHX_ OP *o)
4946 PERL_ARGS_ASSERT_SEARCH_CONST;
4948 switch (o->op_type) {
4952 if (o->op_flags & OPf_KIDS)
4953 return search_const(cUNOPo->op_first);
4960 if (!(o->op_flags & OPf_KIDS))
4962 kid = cLISTOPo->op_first;
4964 switch (kid->op_type) {
4968 kid = kid->op_sibling;
4971 if (kid != cLISTOPo->op_last)
4977 kid = cLISTOPo->op_last;
4979 return search_const(kid);
4987 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4995 int prepend_not = 0;
4997 PERL_ARGS_ASSERT_NEW_LOGOP;
5002 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5003 return newBINOP(type, flags, scalar(first), scalar(other));
5005 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5007 scalarboolean(first);
5008 /* optimize AND and OR ops that have NOTs as children */
5009 if (first->op_type == OP_NOT
5010 && (first->op_flags & OPf_KIDS)
5011 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5012 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5014 if (type == OP_AND || type == OP_OR) {
5020 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5022 prepend_not = 1; /* prepend a NOT op later */
5026 /* search for a constant op that could let us fold the test */
5027 if ((cstop = search_const(first))) {
5028 if (cstop->op_private & OPpCONST_STRICT)
5029 no_bareword_allowed(cstop);
5030 else if ((cstop->op_private & OPpCONST_BARE))
5031 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5032 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5033 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5034 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5036 if (other->op_type == OP_CONST)
5037 other->op_private |= OPpCONST_SHORTCIRCUIT;
5039 OP *newop = newUNOP(OP_NULL, 0, other);
5040 op_getmad(first, newop, '1');
5041 newop->op_targ = type; /* set "was" field */
5045 if (other->op_type == OP_LEAVE)
5046 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5047 else if (other->op_type == OP_MATCH
5048 || other->op_type == OP_SUBST
5049 || other->op_type == OP_TRANSR
5050 || other->op_type == OP_TRANS)
5051 /* Mark the op as being unbindable with =~ */
5052 other->op_flags |= OPf_SPECIAL;
5056 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5057 const OP *o2 = other;
5058 if ( ! (o2->op_type == OP_LIST
5059 && (( o2 = cUNOPx(o2)->op_first))
5060 && o2->op_type == OP_PUSHMARK
5061 && (( o2 = o2->op_sibling)) )
5064 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5065 || o2->op_type == OP_PADHV)
5066 && o2->op_private & OPpLVAL_INTRO
5067 && !(o2->op_private & OPpPAD_STATE))
5069 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5070 "Deprecated use of my() in false conditional");
5074 if (first->op_type == OP_CONST)
5075 first->op_private |= OPpCONST_SHORTCIRCUIT;
5077 first = newUNOP(OP_NULL, 0, first);
5078 op_getmad(other, first, '2');
5079 first->op_targ = type; /* set "was" field */
5086 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5087 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5089 const OP * const k1 = ((UNOP*)first)->op_first;
5090 const OP * const k2 = k1->op_sibling;
5092 switch (first->op_type)
5095 if (k2 && k2->op_type == OP_READLINE
5096 && (k2->op_flags & OPf_STACKED)
5097 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5099 warnop = k2->op_type;
5104 if (k1->op_type == OP_READDIR
5105 || k1->op_type == OP_GLOB
5106 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5107 || k1->op_type == OP_EACH
5108 || k1->op_type == OP_AEACH)
5110 warnop = ((k1->op_type == OP_NULL)
5111 ? (OPCODE)k1->op_targ : k1->op_type);
5116 const line_t oldline = CopLINE(PL_curcop);
5117 CopLINE_set(PL_curcop, PL_parser->copline);
5118 Perl_warner(aTHX_ packWARN(WARN_MISC),
5119 "Value of %s%s can be \"0\"; test with defined()",
5121 ((warnop == OP_READLINE || warnop == OP_GLOB)
5122 ? " construct" : "() operator"));
5123 CopLINE_set(PL_curcop, oldline);
5130 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5131 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5133 NewOp(1101, logop, 1, LOGOP);
5135 logop->op_type = (OPCODE)type;
5136 logop->op_ppaddr = PL_ppaddr[type];
5137 logop->op_first = first;
5138 logop->op_flags = (U8)(flags | OPf_KIDS);
5139 logop->op_other = LINKLIST(other);
5140 logop->op_private = (U8)(1 | (flags >> 8));
5142 /* establish postfix order */
5143 logop->op_next = LINKLIST(first);
5144 first->op_next = (OP*)logop;
5145 first->op_sibling = other;
5147 CHECKOP(type,logop);
5149 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5156 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5158 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5159 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5160 will be set automatically, and, shifted up eight bits, the eight bits of
5161 C<op_private>, except that the bit with value 1 is automatically set.
5162 I<first> supplies the expression selecting between the two branches,
5163 and I<trueop> and I<falseop> supply the branches; they are consumed by
5164 this function and become part of the constructed op tree.
5170 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5178 PERL_ARGS_ASSERT_NEWCONDOP;
5181 return newLOGOP(OP_AND, 0, first, trueop);
5183 return newLOGOP(OP_OR, 0, first, falseop);
5185 scalarboolean(first);
5186 if ((cstop = search_const(first))) {
5187 /* Left or right arm of the conditional? */
5188 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5189 OP *live = left ? trueop : falseop;
5190 OP *const dead = left ? falseop : trueop;
5191 if (cstop->op_private & OPpCONST_BARE &&
5192 cstop->op_private & OPpCONST_STRICT) {
5193 no_bareword_allowed(cstop);
5196 /* This is all dead code when PERL_MAD is not defined. */
5197 live = newUNOP(OP_NULL, 0, live);
5198 op_getmad(first, live, 'C');
5199 op_getmad(dead, live, left ? 'e' : 't');
5204 if (live->op_type == OP_LEAVE)
5205 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5206 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5207 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5208 /* Mark the op as being unbindable with =~ */
5209 live->op_flags |= OPf_SPECIAL;
5212 NewOp(1101, logop, 1, LOGOP);
5213 logop->op_type = OP_COND_EXPR;
5214 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5215 logop->op_first = first;
5216 logop->op_flags = (U8)(flags | OPf_KIDS);
5217 logop->op_private = (U8)(1 | (flags >> 8));
5218 logop->op_other = LINKLIST(trueop);
5219 logop->op_next = LINKLIST(falseop);
5221 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5224 /* establish postfix order */
5225 start = LINKLIST(first);
5226 first->op_next = (OP*)logop;
5228 first->op_sibling = trueop;
5229 trueop->op_sibling = falseop;
5230 o = newUNOP(OP_NULL, 0, (OP*)logop);
5232 trueop->op_next = falseop->op_next = o;
5239 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5241 Constructs and returns a C<range> op, with subordinate C<flip> and
5242 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5243 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5244 for both the C<flip> and C<range> ops, except that the bit with value
5245 1 is automatically set. I<left> and I<right> supply the expressions
5246 controlling the endpoints of the range; they are consumed by this function
5247 and become part of the constructed op tree.
5253 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5262 PERL_ARGS_ASSERT_NEWRANGE;
5264 NewOp(1101, range, 1, LOGOP);
5266 range->op_type = OP_RANGE;
5267 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5268 range->op_first = left;
5269 range->op_flags = OPf_KIDS;
5270 leftstart = LINKLIST(left);
5271 range->op_other = LINKLIST(right);
5272 range->op_private = (U8)(1 | (flags >> 8));
5274 left->op_sibling = right;
5276 range->op_next = (OP*)range;
5277 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5278 flop = newUNOP(OP_FLOP, 0, flip);
5279 o = newUNOP(OP_NULL, 0, flop);
5281 range->op_next = leftstart;
5283 left->op_next = flip;
5284 right->op_next = flop;
5286 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5287 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5288 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5289 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5291 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5292 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5295 if (!flip->op_private || !flop->op_private)
5296 LINKLIST(o); /* blow off optimizer unless constant */
5302 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5304 Constructs, checks, and returns an op tree expressing a loop. This is
5305 only a loop in the control flow through the op tree; it does not have
5306 the heavyweight loop structure that allows exiting the loop by C<last>
5307 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5308 top-level op, except that some bits will be set automatically as required.
5309 I<expr> supplies the expression controlling loop iteration, and I<block>
5310 supplies the body of the loop; they are consumed by this function and
5311 become part of the constructed op tree. I<debuggable> is currently
5312 unused and should always be 1.
5318 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5323 const bool once = block && block->op_flags & OPf_SPECIAL &&
5324 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5326 PERL_UNUSED_ARG(debuggable);
5329 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5330 return block; /* do {} while 0 does once */
5331 if (expr->op_type == OP_READLINE
5332 || expr->op_type == OP_READDIR
5333 || expr->op_type == OP_GLOB
5334 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5335 expr = newUNOP(OP_DEFINED, 0,
5336 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5337 } else if (expr->op_flags & OPf_KIDS) {
5338 const OP * const k1 = ((UNOP*)expr)->op_first;
5339 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5340 switch (expr->op_type) {
5342 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5343 && (k2->op_flags & OPf_STACKED)
5344 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5345 expr = newUNOP(OP_DEFINED, 0, expr);
5349 if (k1 && (k1->op_type == OP_READDIR
5350 || k1->op_type == OP_GLOB
5351 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5352 || k1->op_type == OP_EACH
5353 || k1->op_type == OP_AEACH))
5354 expr = newUNOP(OP_DEFINED, 0, expr);
5360 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5361 * op, in listop. This is wrong. [perl #27024] */
5363 block = newOP(OP_NULL, 0);
5364 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5365 o = new_logop(OP_AND, 0, &expr, &listop);
5368 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5370 if (once && o != listop)
5371 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5374 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5376 o->op_flags |= flags;
5378 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5383 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5385 Constructs, checks, and returns an op tree expressing a C<while> loop.
5386 This is a heavyweight loop, with structure that allows exiting the loop
5387 by C<last> and suchlike.
5389 I<loop> is an optional preconstructed C<enterloop> op to use in the
5390 loop; if it is null then a suitable op will be constructed automatically.
5391 I<expr> supplies the loop's controlling expression. I<block> supplies the
5392 main body of the loop, and I<cont> optionally supplies a C<continue> block
5393 that operates as a second half of the body. All of these optree inputs
5394 are consumed by this function and become part of the constructed op tree.
5396 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5397 op and, shifted up eight bits, the eight bits of C<op_private> for
5398 the C<leaveloop> op, except that (in both cases) some bits will be set
5399 automatically. I<debuggable> is currently unused and should always be 1.
5400 I<has_my> can be supplied as true to force the
5401 loop body to be enclosed in its own scope.
5407 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5408 OP *expr, OP *block, OP *cont, I32 has_my)
5417 PERL_UNUSED_ARG(debuggable);
5420 if (expr->op_type == OP_READLINE
5421 || expr->op_type == OP_READDIR
5422 || expr->op_type == OP_GLOB
5423 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5424 expr = newUNOP(OP_DEFINED, 0,
5425 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5426 } else if (expr->op_flags & OPf_KIDS) {
5427 const OP * const k1 = ((UNOP*)expr)->op_first;
5428 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5429 switch (expr->op_type) {
5431 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5432 && (k2->op_flags & OPf_STACKED)
5433 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5434 expr = newUNOP(OP_DEFINED, 0, expr);
5438 if (k1 && (k1->op_type == OP_READDIR
5439 || k1->op_type == OP_GLOB
5440 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5441 || k1->op_type == OP_EACH
5442 || k1->op_type == OP_AEACH))
5443 expr = newUNOP(OP_DEFINED, 0, expr);
5450 block = newOP(OP_NULL, 0);
5451 else if (cont || has_my) {
5452 block = op_scope(block);
5456 next = LINKLIST(cont);
5459 OP * const unstack = newOP(OP_UNSTACK, 0);
5462 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5466 listop = op_append_list(OP_LINESEQ, block, cont);
5468 redo = LINKLIST(listop);
5472 o = new_logop(OP_AND, 0, &expr, &listop);
5473 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5474 op_free(expr); /* oops, it's a while (0) */
5476 return NULL; /* listop already freed by new_logop */
5479 ((LISTOP*)listop)->op_last->op_next =
5480 (o == listop ? redo : LINKLIST(o));
5486 NewOp(1101,loop,1,LOOP);
5487 loop->op_type = OP_ENTERLOOP;
5488 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5489 loop->op_private = 0;
5490 loop->op_next = (OP*)loop;
5493 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5495 loop->op_redoop = redo;
5496 loop->op_lastop = o;
5497 o->op_private |= loopflags;
5500 loop->op_nextop = next;
5502 loop->op_nextop = o;
5504 o->op_flags |= flags;
5505 o->op_private |= (flags >> 8);
5510 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5512 Constructs, checks, and returns an op tree expressing a C<foreach>
5513 loop (iteration through a list of values). This is a heavyweight loop,
5514 with structure that allows exiting the loop by C<last> and suchlike.
5516 I<sv> optionally supplies the variable that will be aliased to each
5517 item in turn; if null, it defaults to C<$_> (either lexical or global).
5518 I<expr> supplies the list of values to iterate over. I<block> supplies
5519 the main body of the loop, and I<cont> optionally supplies a C<continue>
5520 block that operates as a second half of the body. All of these optree
5521 inputs are consumed by this function and become part of the constructed
5524 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5525 op and, shifted up eight bits, the eight bits of C<op_private> for
5526 the C<leaveloop> op, except that (in both cases) some bits will be set
5533 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5538 PADOFFSET padoff = 0;
5543 PERL_ARGS_ASSERT_NEWFOROP;
5546 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5547 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5548 sv->op_type = OP_RV2GV;
5549 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5551 /* The op_type check is needed to prevent a possible segfault
5552 * if the loop variable is undeclared and 'strict vars' is in
5553 * effect. This is illegal but is nonetheless parsed, so we
5554 * may reach this point with an OP_CONST where we're expecting
5557 if (cUNOPx(sv)->op_first->op_type == OP_GV
5558 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5559 iterpflags |= OPpITER_DEF;
5561 else if (sv->op_type == OP_PADSV) { /* private variable */
5562 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5563 padoff = sv->op_targ;
5573 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5575 SV *const namesv = PAD_COMPNAME_SV(padoff);
5577 const char *const name = SvPV_const(namesv, len);
5579 if (len == 2 && name[0] == '$' && name[1] == '_')
5580 iterpflags |= OPpITER_DEF;
5584 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5585 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5586 sv = newGVOP(OP_GV, 0, PL_defgv);
5591 iterpflags |= OPpITER_DEF;
5593 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5594 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5595 iterflags |= OPf_STACKED;
5597 else if (expr->op_type == OP_NULL &&
5598 (expr->op_flags & OPf_KIDS) &&
5599 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5601 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5602 * set the STACKED flag to indicate that these values are to be
5603 * treated as min/max values by 'pp_iterinit'.
5605 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5606 LOGOP* const range = (LOGOP*) flip->op_first;
5607 OP* const left = range->op_first;
5608 OP* const right = left->op_sibling;
5611 range->op_flags &= ~OPf_KIDS;
5612 range->op_first = NULL;
5614 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5615 listop->op_first->op_next = range->op_next;
5616 left->op_next = range->op_other;
5617 right->op_next = (OP*)listop;
5618 listop->op_next = listop->op_first;
5621 op_getmad(expr,(OP*)listop,'O');
5625 expr = (OP*)(listop);
5627 iterflags |= OPf_STACKED;
5630 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5633 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5634 op_append_elem(OP_LIST, expr, scalar(sv))));
5635 assert(!loop->op_next);
5636 /* for my $x () sets OPpLVAL_INTRO;
5637 * for our $x () sets OPpOUR_INTRO */
5638 loop->op_private = (U8)iterpflags;
5639 #ifdef PL_OP_SLAB_ALLOC
5642 NewOp(1234,tmp,1,LOOP);
5643 Copy(loop,tmp,1,LISTOP);
5644 S_op_destroy(aTHX_ (OP*)loop);
5648 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5650 loop->op_targ = padoff;
5651 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5653 op_getmad(madsv, (OP*)loop, 'v');
5658 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5660 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5661 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5662 determining the target of the op; it is consumed by this function and
5663 become part of the constructed op tree.
5669 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5674 PERL_ARGS_ASSERT_NEWLOOPEX;
5676 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5678 if (type != OP_GOTO || label->op_type == OP_CONST) {
5679 /* "last()" means "last" */
5680 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5681 o = newOP(type, OPf_SPECIAL);
5683 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5684 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5688 op_getmad(label,o,'L');
5694 /* Check whether it's going to be a goto &function */
5695 if (label->op_type == OP_ENTERSUB
5696 && !(label->op_flags & OPf_STACKED))
5697 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5698 o = newUNOP(type, OPf_STACKED, label);
5700 PL_hints |= HINT_BLOCK_SCOPE;
5704 /* if the condition is a literal array or hash
5705 (or @{ ... } etc), make a reference to it.
5708 S_ref_array_or_hash(pTHX_ OP *cond)
5711 && (cond->op_type == OP_RV2AV
5712 || cond->op_type == OP_PADAV
5713 || cond->op_type == OP_RV2HV
5714 || cond->op_type == OP_PADHV))
5716 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5719 && (cond->op_type == OP_ASLICE
5720 || cond->op_type == OP_HSLICE)) {
5722 /* anonlist now needs a list from this op, was previously used in
5724 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5725 cond->op_flags |= OPf_WANT_LIST;
5727 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5734 /* These construct the optree fragments representing given()
5737 entergiven and enterwhen are LOGOPs; the op_other pointer
5738 points up to the associated leave op. We need this so we
5739 can put it in the context and make break/continue work.
5740 (Also, of course, pp_enterwhen will jump straight to
5741 op_other if the match fails.)
5745 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5746 I32 enter_opcode, I32 leave_opcode,
5747 PADOFFSET entertarg)
5753 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5755 NewOp(1101, enterop, 1, LOGOP);
5756 enterop->op_type = (Optype)enter_opcode;
5757 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5758 enterop->op_flags = (U8) OPf_KIDS;
5759 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5760 enterop->op_private = 0;
5762 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5765 enterop->op_first = scalar(cond);
5766 cond->op_sibling = block;
5768 o->op_next = LINKLIST(cond);
5769 cond->op_next = (OP *) enterop;
5772 /* This is a default {} block */
5773 enterop->op_first = block;
5774 enterop->op_flags |= OPf_SPECIAL;
5776 o->op_next = (OP *) enterop;
5779 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5780 entergiven and enterwhen both
5783 enterop->op_next = LINKLIST(block);
5784 block->op_next = enterop->op_other = o;
5789 /* Does this look like a boolean operation? For these purposes
5790 a boolean operation is:
5791 - a subroutine call [*]
5792 - a logical connective
5793 - a comparison operator
5794 - a filetest operator, with the exception of -s -M -A -C
5795 - defined(), exists() or eof()
5796 - /$re/ or $foo =~ /$re/
5798 [*] possibly surprising
5801 S_looks_like_bool(pTHX_ const OP *o)
5805 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5807 switch(o->op_type) {
5810 return looks_like_bool(cLOGOPo->op_first);
5814 looks_like_bool(cLOGOPo->op_first)
5815 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5820 o->op_flags & OPf_KIDS
5821 && looks_like_bool(cUNOPo->op_first));
5825 case OP_NOT: case OP_XOR:
5827 case OP_EQ: case OP_NE: case OP_LT:
5828 case OP_GT: case OP_LE: case OP_GE:
5830 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5831 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5833 case OP_SEQ: case OP_SNE: case OP_SLT:
5834 case OP_SGT: case OP_SLE: case OP_SGE:
5838 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5839 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5840 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5841 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5842 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5843 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5844 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5845 case OP_FTTEXT: case OP_FTBINARY:
5847 case OP_DEFINED: case OP_EXISTS:
5848 case OP_MATCH: case OP_EOF:
5855 /* Detect comparisons that have been optimized away */
5856 if (cSVOPo->op_sv == &PL_sv_yes
5857 || cSVOPo->op_sv == &PL_sv_no)
5870 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5872 Constructs, checks, and returns an op tree expressing a C<given> block.
5873 I<cond> supplies the expression that will be locally assigned to a lexical
5874 variable, and I<block> supplies the body of the C<given> construct; they
5875 are consumed by this function and become part of the constructed op tree.
5876 I<defsv_off> is the pad offset of the scalar lexical variable that will
5883 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5886 PERL_ARGS_ASSERT_NEWGIVENOP;
5887 return newGIVWHENOP(
5888 ref_array_or_hash(cond),
5890 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5895 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5897 Constructs, checks, and returns an op tree expressing a C<when> block.
5898 I<cond> supplies the test expression, and I<block> supplies the block
5899 that will be executed if the test evaluates to true; they are consumed
5900 by this function and become part of the constructed op tree. I<cond>
5901 will be interpreted DWIMically, often as a comparison against C<$_>,
5902 and may be null to generate a C<default> block.
5908 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5910 const bool cond_llb = (!cond || looks_like_bool(cond));
5913 PERL_ARGS_ASSERT_NEWWHENOP;
5918 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5920 scalar(ref_array_or_hash(cond)));
5923 return newGIVWHENOP(
5925 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5926 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5930 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5933 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5935 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5936 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5937 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5938 || (p && (len != SvCUR(cv) /* Not the same length. */
5939 || memNE(p, SvPVX_const(cv), len))))
5940 && ckWARN_d(WARN_PROTOTYPE)) {
5941 SV* const msg = sv_newmortal();
5945 gv_efullname3(name = sv_newmortal(), gv, NULL);
5946 sv_setpvs(msg, "Prototype mismatch:");
5948 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5950 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5952 sv_catpvs(msg, ": none");
5953 sv_catpvs(msg, " vs ");
5955 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5957 sv_catpvs(msg, "none");
5958 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5962 static void const_sv_xsub(pTHX_ CV* cv);
5966 =head1 Optree Manipulation Functions
5968 =for apidoc cv_const_sv
5970 If C<cv> is a constant sub eligible for inlining. returns the constant
5971 value returned by the sub. Otherwise, returns NULL.
5973 Constant subs can be created with C<newCONSTSUB> or as described in
5974 L<perlsub/"Constant Functions">.
5979 Perl_cv_const_sv(pTHX_ const CV *const cv)
5981 PERL_UNUSED_CONTEXT;
5984 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5986 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5989 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5990 * Can be called in 3 ways:
5993 * look for a single OP_CONST with attached value: return the value
5995 * cv && CvCLONE(cv) && !CvCONST(cv)
5997 * examine the clone prototype, and if contains only a single
5998 * OP_CONST referencing a pad const, or a single PADSV referencing
5999 * an outer lexical, return a non-zero value to indicate the CV is
6000 * a candidate for "constizing" at clone time
6004 * We have just cloned an anon prototype that was marked as a const
6005 * candidate. Try to grab the current value, and in the case of
6006 * PADSV, ignore it if it has multiple references. Return the value.
6010 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6021 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6022 o = cLISTOPo->op_first->op_sibling;
6024 for (; o; o = o->op_next) {
6025 const OPCODE type = o->op_type;
6027 if (sv && o->op_next == o)
6029 if (o->op_next != o) {
6030 if (type == OP_NEXTSTATE
6031 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6032 || type == OP_PUSHMARK)
6034 if (type == OP_DBSTATE)
6037 if (type == OP_LEAVESUB || type == OP_RETURN)
6041 if (type == OP_CONST && cSVOPo->op_sv)
6043 else if (cv && type == OP_CONST) {
6044 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6048 else if (cv && type == OP_PADSV) {
6049 if (CvCONST(cv)) { /* newly cloned anon */
6050 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6051 /* the candidate should have 1 ref from this pad and 1 ref
6052 * from the parent */
6053 if (!sv || SvREFCNT(sv) != 2)
6060 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6061 sv = &PL_sv_undef; /* an arbitrary non-null value */
6076 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6079 /* This would be the return value, but the return cannot be reached. */
6080 OP* pegop = newOP(OP_NULL, 0);
6083 PERL_UNUSED_ARG(floor);
6093 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6095 NORETURN_FUNCTION_END;
6100 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6105 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6106 register CV *cv = NULL;
6108 /* If the subroutine has no body, no attributes, and no builtin attributes
6109 then it's just a sub declaration, and we may be able to get away with
6110 storing with a placeholder scalar in the symbol table, rather than a
6111 full GV and CV. If anything is present then it will take a full CV to
6113 const I32 gv_fetch_flags
6114 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6116 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6117 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6121 assert(proto->op_type == OP_CONST);
6122 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6128 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6130 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6131 SV * const sv = sv_newmortal();
6132 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6133 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6134 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6135 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6137 } else if (PL_curstash) {
6138 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6141 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6145 if (!PL_madskills) {
6154 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6155 maximum a prototype before. */
6156 if (SvTYPE(gv) > SVt_NULL) {
6157 if (!SvPOK((const SV *)gv)
6158 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6160 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6162 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6165 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6167 sv_setiv(MUTABLE_SV(gv), -1);
6169 SvREFCNT_dec(PL_compcv);
6170 cv = PL_compcv = NULL;
6174 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6176 if (!block || !ps || *ps || attrs
6177 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6179 || block->op_type == OP_NULL
6184 const_sv = op_const_sv(block, NULL);
6187 const bool exists = CvROOT(cv) || CvXSUB(cv);
6189 /* if the subroutine doesn't exist and wasn't pre-declared
6190 * with a prototype, assume it will be AUTOLOADed,
6191 * skipping the prototype check
6193 if (exists || SvPOK(cv))
6194 cv_ckproto_len(cv, gv, ps, ps_len);
6195 /* already defined (or promised)? */
6196 if (exists || GvASSUMECV(gv)) {
6199 || block->op_type == OP_NULL
6202 if (CvFLAGS(PL_compcv)) {
6203 /* might have had built-in attrs applied */
6204 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6205 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6206 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6208 /* just a "sub foo;" when &foo is already defined */
6209 SAVEFREESV(PL_compcv);
6214 && block->op_type != OP_NULL
6217 if (ckWARN(WARN_REDEFINE)
6219 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6221 const line_t oldline = CopLINE(PL_curcop);
6222 if (PL_parser && PL_parser->copline != NOLINE)
6223 CopLINE_set(PL_curcop, PL_parser->copline);
6224 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6225 CvCONST(cv) ? "Constant subroutine %s redefined"
6226 : "Subroutine %s redefined", name);
6227 CopLINE_set(PL_curcop, oldline);
6230 if (!PL_minus_c) /* keep old one around for madskills */
6233 /* (PL_madskills unset in used file.) */
6241 SvREFCNT_inc_simple_void_NN(const_sv);
6243 assert(!CvROOT(cv) && !CvCONST(cv));
6244 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6245 CvXSUBANY(cv).any_ptr = const_sv;
6246 CvXSUB(cv) = const_sv_xsub;
6252 cv = newCONSTSUB(NULL, name, const_sv);
6254 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6255 (CvGV(cv) && GvSTASH(CvGV(cv)))
6264 SvREFCNT_dec(PL_compcv);
6268 if (cv) { /* must reuse cv if autoloaded */
6269 /* transfer PL_compcv to cv */
6272 && block->op_type != OP_NULL
6275 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6276 AV *const temp_av = CvPADLIST(cv);
6277 CV *const temp_cv = CvOUTSIDE(cv);
6279 assert(!CvWEAKOUTSIDE(cv));
6280 assert(!CvCVGV_RC(cv));
6281 assert(CvGV(cv) == gv);
6284 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6285 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6286 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6287 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6288 CvOUTSIDE(PL_compcv) = temp_cv;
6289 CvPADLIST(PL_compcv) = temp_av;
6292 if (CvFILE(cv) && !CvISXSUB(cv)) {
6293 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6294 Safefree(CvFILE(cv));
6297 CvFILE_set_from_cop(cv, PL_curcop);
6298 CvSTASH_set(cv, PL_curstash);
6300 /* inner references to PL_compcv must be fixed up ... */
6301 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6302 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6303 ++PL_sub_generation;
6306 /* Might have had built-in attributes applied -- propagate them. */
6307 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6309 /* ... before we throw it away */
6310 SvREFCNT_dec(PL_compcv);
6318 if (strEQ(name, "import")) {
6319 PL_formfeed = MUTABLE_SV(cv);
6320 /* diag_listed_as: SKIPME */
6321 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6325 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6330 CvFILE_set_from_cop(cv, PL_curcop);
6331 CvSTASH_set(cv, PL_curstash);
6334 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6335 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6336 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6340 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6342 if (PL_parser && PL_parser->error_count) {
6346 const char *s = strrchr(name, ':');
6348 if (strEQ(s, "BEGIN")) {
6349 const char not_safe[] =
6350 "BEGIN not safe after errors--compilation aborted";
6351 if (PL_in_eval & EVAL_KEEPERR)
6352 Perl_croak(aTHX_ not_safe);
6354 /* force display of errors found but not reported */
6355 sv_catpv(ERRSV, not_safe);
6356 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6365 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6366 the debugger could be able to set a breakpoint in, so signal to
6367 pp_entereval that it should not throw away any saved lines at scope
6370 PL_breakable_sub_gen++;
6371 /* This makes sub {}; work as expected. */
6372 if (block->op_type == OP_STUB) {
6373 OP* const newblock = newSTATEOP(0, NULL, 0);
6375 op_getmad(block,newblock,'B');
6381 else block->op_attached = 1;
6382 CvROOT(cv) = CvLVALUE(cv)
6383 ? newUNOP(OP_LEAVESUBLV, 0,
6384 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6385 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6386 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6387 OpREFCNT_set(CvROOT(cv), 1);
6388 CvSTART(cv) = LINKLIST(CvROOT(cv));
6389 CvROOT(cv)->op_next = 0;
6390 CALL_PEEP(CvSTART(cv));
6392 /* now that optimizer has done its work, adjust pad values */
6394 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6397 assert(!CvCONST(cv));
6398 if (ps && !*ps && op_const_sv(block, cv))
6403 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6404 SV * const tmpstr = sv_newmortal();
6405 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6406 GV_ADDMULTI, SVt_PVHV);
6408 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6411 (long)CopLINE(PL_curcop));
6412 gv_efullname3(tmpstr, gv, NULL);
6413 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6414 SvCUR(tmpstr), sv, 0);
6415 hv = GvHVn(db_postponed);
6416 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6417 CV * const pcv = GvCV(db_postponed);
6423 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6428 if (name && ! (PL_parser && PL_parser->error_count))
6429 process_special_blocks(name, gv, cv);
6434 PL_parser->copline = NOLINE;
6440 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6443 const char *const colon = strrchr(fullname,':');
6444 const char *const name = colon ? colon + 1 : fullname;
6446 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6449 if (strEQ(name, "BEGIN")) {
6450 const I32 oldscope = PL_scopestack_ix;
6452 SAVECOPFILE(&PL_compiling);
6453 SAVECOPLINE(&PL_compiling);
6455 DEBUG_x( dump_sub(gv) );
6456 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6457 GvCV_set(gv,0); /* cv has been hijacked */
6458 call_list(oldscope, PL_beginav);
6460 PL_curcop = &PL_compiling;
6461 CopHINTS_set(&PL_compiling, PL_hints);
6468 if strEQ(name, "END") {
6469 DEBUG_x( dump_sub(gv) );
6470 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6473 } else if (*name == 'U') {
6474 if (strEQ(name, "UNITCHECK")) {
6475 /* It's never too late to run a unitcheck block */
6476 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6480 } else if (*name == 'C') {
6481 if (strEQ(name, "CHECK")) {
6483 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6484 "Too late to run CHECK block");
6485 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6489 } else if (*name == 'I') {
6490 if (strEQ(name, "INIT")) {
6492 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6493 "Too late to run INIT block");
6494 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6500 DEBUG_x( dump_sub(gv) );
6501 GvCV_set(gv,0); /* cv has been hijacked */
6506 =for apidoc newCONSTSUB
6508 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6509 eligible for inlining at compile-time.
6511 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6512 which won't be called if used as a destructor, but will suppress the overhead
6513 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6520 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6525 const char *const file = CopFILE(PL_curcop);
6527 SV *const temp_sv = CopFILESV(PL_curcop);
6528 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6533 if (IN_PERL_RUNTIME) {
6534 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6535 * an op shared between threads. Use a non-shared COP for our
6537 SAVEVPTR(PL_curcop);
6538 PL_curcop = &PL_compiling;
6540 SAVECOPLINE(PL_curcop);
6541 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6544 PL_hints &= ~HINT_BLOCK_SCOPE;
6547 SAVESPTR(PL_curstash);
6548 SAVECOPSTASH(PL_curcop);
6549 PL_curstash = stash;
6550 CopSTASH_set(PL_curcop,stash);
6553 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6554 and so doesn't get free()d. (It's expected to be from the C pre-
6555 processor __FILE__ directive). But we need a dynamically allocated one,
6556 and we need it to get freed. */
6557 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6558 XS_DYNAMIC_FILENAME);
6559 CvXSUBANY(cv).any_ptr = sv;
6564 CopSTASH_free(PL_curcop);
6572 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6573 const char *const filename, const char *const proto,
6576 CV *cv = newXS(name, subaddr, filename);
6578 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6580 if (flags & XS_DYNAMIC_FILENAME) {
6581 /* We need to "make arrangements" (ie cheat) to ensure that the
6582 filename lasts as long as the PVCV we just created, but also doesn't
6584 STRLEN filename_len = strlen(filename);
6585 STRLEN proto_and_file_len = filename_len;
6586 char *proto_and_file;
6590 proto_len = strlen(proto);
6591 proto_and_file_len += proto_len;
6593 Newx(proto_and_file, proto_and_file_len + 1, char);
6594 Copy(proto, proto_and_file, proto_len, char);
6595 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6598 proto_and_file = savepvn(filename, filename_len);
6601 /* This gets free()d. :-) */
6602 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6603 SV_HAS_TRAILING_NUL);
6605 /* This gives us the correct prototype, rather than one with the
6606 file name appended. */
6607 SvCUR_set(cv, proto_len);
6611 CvFILE(cv) = proto_and_file + proto_len;
6613 sv_setpv(MUTABLE_SV(cv), proto);
6619 =for apidoc U||newXS
6621 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6622 static storage, as it is used directly as CvFILE(), without a copy being made.
6628 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6631 GV * const gv = gv_fetchpv(name ? name :
6632 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6633 GV_ADDMULTI, SVt_PVCV);
6636 PERL_ARGS_ASSERT_NEWXS;
6639 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6641 if ((cv = (name ? GvCV(gv) : NULL))) {
6643 /* just a cached method */
6647 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6648 /* already defined (or promised) */
6649 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6650 if (ckWARN(WARN_REDEFINE)) {
6651 GV * const gvcv = CvGV(cv);
6653 HV * const stash = GvSTASH(gvcv);
6655 const char *redefined_name = HvNAME_get(stash);
6656 if ( strEQ(redefined_name,"autouse") ) {
6657 const line_t oldline = CopLINE(PL_curcop);
6658 if (PL_parser && PL_parser->copline != NOLINE)
6659 CopLINE_set(PL_curcop, PL_parser->copline);
6660 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6661 CvCONST(cv) ? "Constant subroutine %s redefined"
6662 : "Subroutine %s redefined"
6664 CopLINE_set(PL_curcop, oldline);
6674 if (cv) /* must reuse cv if autoloaded */
6677 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6681 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6687 (void)gv_fetchfile(filename);
6688 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6689 an external constant string */
6691 CvXSUB(cv) = subaddr;
6694 process_special_blocks(name, gv, cv);
6704 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6709 OP* pegop = newOP(OP_NULL, 0);
6713 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6714 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6717 if ((cv = GvFORM(gv))) {
6718 if (ckWARN(WARN_REDEFINE)) {
6719 const line_t oldline = CopLINE(PL_curcop);
6720 if (PL_parser && PL_parser->copline != NOLINE)
6721 CopLINE_set(PL_curcop, PL_parser->copline);
6723 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6724 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6726 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6727 "Format STDOUT redefined");
6729 CopLINE_set(PL_curcop, oldline);
6736 CvFILE_set_from_cop(cv, PL_curcop);
6739 pad_tidy(padtidy_FORMAT);
6740 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6741 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6742 OpREFCNT_set(CvROOT(cv), 1);
6743 CvSTART(cv) = LINKLIST(CvROOT(cv));
6744 CvROOT(cv)->op_next = 0;
6745 CALL_PEEP(CvSTART(cv));
6747 op_getmad(o,pegop,'n');
6748 op_getmad_weak(block, pegop, 'b');
6753 PL_parser->copline = NOLINE;
6761 Perl_newANONLIST(pTHX_ OP *o)
6763 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6767 Perl_newANONHASH(pTHX_ OP *o)
6769 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6773 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6775 return newANONATTRSUB(floor, proto, NULL, block);
6779 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6781 return newUNOP(OP_REFGEN, 0,
6782 newSVOP(OP_ANONCODE, 0,
6783 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6787 Perl_oopsAV(pTHX_ OP *o)
6791 PERL_ARGS_ASSERT_OOPSAV;
6793 switch (o->op_type) {
6795 o->op_type = OP_PADAV;
6796 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6797 return ref(o, OP_RV2AV);
6800 o->op_type = OP_RV2AV;
6801 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6806 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6813 Perl_oopsHV(pTHX_ OP *o)
6817 PERL_ARGS_ASSERT_OOPSHV;
6819 switch (o->op_type) {
6822 o->op_type = OP_PADHV;
6823 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6824 return ref(o, OP_RV2HV);
6828 o->op_type = OP_RV2HV;
6829 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6834 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6841 Perl_newAVREF(pTHX_ OP *o)
6845 PERL_ARGS_ASSERT_NEWAVREF;
6847 if (o->op_type == OP_PADANY) {
6848 o->op_type = OP_PADAV;
6849 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6852 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6853 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6854 "Using an array as a reference is deprecated");
6856 return newUNOP(OP_RV2AV, 0, scalar(o));
6860 Perl_newGVREF(pTHX_ I32 type, OP *o)
6862 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6863 return newUNOP(OP_NULL, 0, o);
6864 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6868 Perl_newHVREF(pTHX_ OP *o)
6872 PERL_ARGS_ASSERT_NEWHVREF;
6874 if (o->op_type == OP_PADANY) {
6875 o->op_type = OP_PADHV;
6876 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6879 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6880 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6881 "Using a hash as a reference is deprecated");
6883 return newUNOP(OP_RV2HV, 0, scalar(o));
6887 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6889 return newUNOP(OP_RV2CV, flags, scalar(o));
6893 Perl_newSVREF(pTHX_ OP *o)
6897 PERL_ARGS_ASSERT_NEWSVREF;
6899 if (o->op_type == OP_PADANY) {
6900 o->op_type = OP_PADSV;
6901 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6904 return newUNOP(OP_RV2SV, 0, scalar(o));
6907 /* Check routines. See the comments at the top of this file for details
6908 * on when these are called */
6911 Perl_ck_anoncode(pTHX_ OP *o)
6913 PERL_ARGS_ASSERT_CK_ANONCODE;
6915 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6917 cSVOPo->op_sv = NULL;
6922 Perl_ck_bitop(pTHX_ OP *o)
6926 PERL_ARGS_ASSERT_CK_BITOP;
6928 #define OP_IS_NUMCOMPARE(op) \
6929 ((op) == OP_LT || (op) == OP_I_LT || \
6930 (op) == OP_GT || (op) == OP_I_GT || \
6931 (op) == OP_LE || (op) == OP_I_LE || \
6932 (op) == OP_GE || (op) == OP_I_GE || \
6933 (op) == OP_EQ || (op) == OP_I_EQ || \
6934 (op) == OP_NE || (op) == OP_I_NE || \
6935 (op) == OP_NCMP || (op) == OP_I_NCMP)
6936 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6937 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6938 && (o->op_type == OP_BIT_OR
6939 || o->op_type == OP_BIT_AND
6940 || o->op_type == OP_BIT_XOR))
6942 const OP * const left = cBINOPo->op_first;
6943 const OP * const right = left->op_sibling;
6944 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6945 (left->op_flags & OPf_PARENS) == 0) ||
6946 (OP_IS_NUMCOMPARE(right->op_type) &&
6947 (right->op_flags & OPf_PARENS) == 0))
6948 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6949 "Possible precedence problem on bitwise %c operator",
6950 o->op_type == OP_BIT_OR ? '|'
6951 : o->op_type == OP_BIT_AND ? '&' : '^'
6958 Perl_ck_concat(pTHX_ OP *o)
6960 const OP * const kid = cUNOPo->op_first;
6962 PERL_ARGS_ASSERT_CK_CONCAT;
6963 PERL_UNUSED_CONTEXT;
6965 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6966 !(kUNOP->op_first->op_flags & OPf_MOD))
6967 o->op_flags |= OPf_STACKED;
6972 Perl_ck_spair(pTHX_ OP *o)
6976 PERL_ARGS_ASSERT_CK_SPAIR;
6978 if (o->op_flags & OPf_KIDS) {
6981 const OPCODE type = o->op_type;
6982 o = modkids(ck_fun(o), type);
6983 kid = cUNOPo->op_first;
6984 newop = kUNOP->op_first->op_sibling;
6986 const OPCODE type = newop->op_type;
6987 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6988 type == OP_PADAV || type == OP_PADHV ||
6989 type == OP_RV2AV || type == OP_RV2HV)
6993 op_getmad(kUNOP->op_first,newop,'K');
6995 op_free(kUNOP->op_first);
6997 kUNOP->op_first = newop;
6999 o->op_ppaddr = PL_ppaddr[++o->op_type];
7004 Perl_ck_delete(pTHX_ OP *o)
7006 PERL_ARGS_ASSERT_CK_DELETE;
7010 if (o->op_flags & OPf_KIDS) {
7011 OP * const kid = cUNOPo->op_first;
7012 switch (kid->op_type) {
7014 o->op_flags |= OPf_SPECIAL;
7017 o->op_private |= OPpSLICE;
7020 o->op_flags |= OPf_SPECIAL;
7025 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7028 if (kid->op_private & OPpLVAL_INTRO)
7029 o->op_private |= OPpLVAL_INTRO;
7036 Perl_ck_die(pTHX_ OP *o)
7038 PERL_ARGS_ASSERT_CK_DIE;
7041 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7047 Perl_ck_eof(pTHX_ OP *o)
7051 PERL_ARGS_ASSERT_CK_EOF;
7053 if (o->op_flags & OPf_KIDS) {
7054 if (cLISTOPo->op_first->op_type == OP_STUB) {
7056 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7058 op_getmad(o,newop,'O');
7070 Perl_ck_eval(pTHX_ OP *o)
7074 PERL_ARGS_ASSERT_CK_EVAL;
7076 PL_hints |= HINT_BLOCK_SCOPE;
7077 if (o->op_flags & OPf_KIDS) {
7078 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7081 o->op_flags &= ~OPf_KIDS;
7084 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7090 cUNOPo->op_first = 0;
7095 NewOp(1101, enter, 1, LOGOP);
7096 enter->op_type = OP_ENTERTRY;
7097 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7098 enter->op_private = 0;
7100 /* establish postfix order */
7101 enter->op_next = (OP*)enter;
7103 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7104 o->op_type = OP_LEAVETRY;
7105 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7106 enter->op_other = o;
7107 op_getmad(oldo,o,'O');
7121 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7122 op_getmad(oldo,o,'O');
7124 o->op_targ = (PADOFFSET)PL_hints;
7125 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7126 /* Store a copy of %^H that pp_entereval can pick up. */
7127 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7128 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7129 cUNOPo->op_first->op_sibling = hhop;
7130 o->op_private |= OPpEVAL_HAS_HH;
7136 Perl_ck_exit(pTHX_ OP *o)
7138 PERL_ARGS_ASSERT_CK_EXIT;
7141 HV * const table = GvHV(PL_hintgv);
7143 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7144 if (svp && *svp && SvTRUE(*svp))
7145 o->op_private |= OPpEXIT_VMSISH;
7147 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7153 Perl_ck_exec(pTHX_ OP *o)
7155 PERL_ARGS_ASSERT_CK_EXEC;
7157 if (o->op_flags & OPf_STACKED) {
7160 kid = cUNOPo->op_first->op_sibling;
7161 if (kid->op_type == OP_RV2GV)
7170 Perl_ck_exists(pTHX_ OP *o)
7174 PERL_ARGS_ASSERT_CK_EXISTS;
7177 if (o->op_flags & OPf_KIDS) {
7178 OP * const kid = cUNOPo->op_first;
7179 if (kid->op_type == OP_ENTERSUB) {
7180 (void) ref(kid, o->op_type);
7181 if (kid->op_type != OP_RV2CV
7182 && !(PL_parser && PL_parser->error_count))
7183 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7185 o->op_private |= OPpEXISTS_SUB;
7187 else if (kid->op_type == OP_AELEM)
7188 o->op_flags |= OPf_SPECIAL;
7189 else if (kid->op_type != OP_HELEM)
7190 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7198 Perl_ck_rvconst(pTHX_ register OP *o)
7201 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7203 PERL_ARGS_ASSERT_CK_RVCONST;
7205 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7206 if (o->op_type == OP_RV2CV)
7207 o->op_private &= ~1;
7209 if (kid->op_type == OP_CONST) {
7212 SV * const kidsv = kid->op_sv;
7214 /* Is it a constant from cv_const_sv()? */
7215 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7216 SV * const rsv = SvRV(kidsv);
7217 const svtype type = SvTYPE(rsv);
7218 const char *badtype = NULL;
7220 switch (o->op_type) {
7222 if (type > SVt_PVMG)
7223 badtype = "a SCALAR";
7226 if (type != SVt_PVAV)
7227 badtype = "an ARRAY";
7230 if (type != SVt_PVHV)
7234 if (type != SVt_PVCV)
7239 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7242 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7243 const char *badthing;
7244 switch (o->op_type) {
7246 badthing = "a SCALAR";
7249 badthing = "an ARRAY";
7252 badthing = "a HASH";
7260 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7261 SVfARG(kidsv), badthing);
7264 * This is a little tricky. We only want to add the symbol if we
7265 * didn't add it in the lexer. Otherwise we get duplicate strict
7266 * warnings. But if we didn't add it in the lexer, we must at
7267 * least pretend like we wanted to add it even if it existed before,
7268 * or we get possible typo warnings. OPpCONST_ENTERED says
7269 * whether the lexer already added THIS instance of this symbol.
7271 iscv = (o->op_type == OP_RV2CV) * 2;
7273 gv = gv_fetchsv(kidsv,
7274 iscv | !(kid->op_private & OPpCONST_ENTERED),
7277 : o->op_type == OP_RV2SV
7279 : o->op_type == OP_RV2AV
7281 : o->op_type == OP_RV2HV
7284 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7286 kid->op_type = OP_GV;
7287 SvREFCNT_dec(kid->op_sv);
7289 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7290 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7291 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7293 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7295 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7297 kid->op_private = 0;
7298 kid->op_ppaddr = PL_ppaddr[OP_GV];
7299 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7307 Perl_ck_ftst(pTHX_ OP *o)
7310 const I32 type = o->op_type;
7312 PERL_ARGS_ASSERT_CK_FTST;
7314 if (o->op_flags & OPf_REF) {
7317 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7318 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7319 const OPCODE kidtype = kid->op_type;
7321 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7322 OP * const newop = newGVOP(type, OPf_REF,
7323 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7325 op_getmad(o,newop,'O');
7331 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7332 o->op_private |= OPpFT_ACCESS;
7333 if (PL_check[kidtype] == Perl_ck_ftst
7334 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7335 o->op_private |= OPpFT_STACKED;
7343 if (type == OP_FTTTY)
7344 o = newGVOP(type, OPf_REF, PL_stdingv);
7346 o = newUNOP(type, 0, newDEFSVOP());
7347 op_getmad(oldo,o,'O');
7353 Perl_ck_fun(pTHX_ OP *o)
7356 const int type = o->op_type;
7357 register I32 oa = PL_opargs[type] >> OASHIFT;
7359 PERL_ARGS_ASSERT_CK_FUN;
7361 if (o->op_flags & OPf_STACKED) {
7362 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7365 return no_fh_allowed(o);
7368 if (o->op_flags & OPf_KIDS) {
7369 OP **tokid = &cLISTOPo->op_first;
7370 register OP *kid = cLISTOPo->op_first;
7374 if (kid->op_type == OP_PUSHMARK ||
7375 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7377 tokid = &kid->op_sibling;
7378 kid = kid->op_sibling;
7380 if (!kid && PL_opargs[type] & OA_DEFGV)
7381 *tokid = kid = newDEFSVOP();
7385 sibl = kid->op_sibling;
7387 if (!sibl && kid->op_type == OP_STUB) {
7394 /* list seen where single (scalar) arg expected? */
7395 if (numargs == 1 && !(oa >> 4)
7396 && kid->op_type == OP_LIST && type != OP_SCALAR)
7398 return too_many_arguments(o,PL_op_desc[type]);
7411 if ((type == OP_PUSH || type == OP_UNSHIFT)
7412 && !kid->op_sibling)
7413 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7414 "Useless use of %s with no values",
7417 if (kid->op_type == OP_CONST &&
7418 (kid->op_private & OPpCONST_BARE))
7420 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7421 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7422 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7423 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7424 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7426 op_getmad(kid,newop,'K');
7431 kid->op_sibling = sibl;
7434 else if (kid->op_type == OP_CONST
7435 && ( !SvROK(cSVOPx_sv(kid))
7436 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7438 bad_type(numargs, "array", PL_op_desc[type], kid);
7439 /* Defer checks to run-time if we have a scalar arg */
7440 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7441 op_lvalue(kid, type);
7445 if (kid->op_type == OP_CONST &&
7446 (kid->op_private & OPpCONST_BARE))
7448 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7449 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7450 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7451 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7452 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7454 op_getmad(kid,newop,'K');
7459 kid->op_sibling = sibl;
7462 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7463 bad_type(numargs, "hash", PL_op_desc[type], kid);
7464 op_lvalue(kid, type);
7468 OP * const newop = newUNOP(OP_NULL, 0, kid);
7469 kid->op_sibling = 0;
7471 newop->op_next = newop;
7473 kid->op_sibling = sibl;
7478 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7479 if (kid->op_type == OP_CONST &&
7480 (kid->op_private & OPpCONST_BARE))
7482 OP * const newop = newGVOP(OP_GV, 0,
7483 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7484 if (!(o->op_private & 1) && /* if not unop */
7485 kid == cLISTOPo->op_last)
7486 cLISTOPo->op_last = newop;
7488 op_getmad(kid,newop,'K');
7494 else if (kid->op_type == OP_READLINE) {
7495 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7496 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7499 I32 flags = OPf_SPECIAL;
7503 /* is this op a FH constructor? */
7504 if (is_handle_constructor(o,numargs)) {
7505 const char *name = NULL;
7509 /* Set a flag to tell rv2gv to vivify
7510 * need to "prove" flag does not mean something
7511 * else already - NI-S 1999/05/07
7514 if (kid->op_type == OP_PADSV) {
7516 = PAD_COMPNAME_SV(kid->op_targ);
7517 name = SvPV_const(namesv, len);
7519 else if (kid->op_type == OP_RV2SV
7520 && kUNOP->op_first->op_type == OP_GV)
7522 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7524 len = GvNAMELEN(gv);
7526 else if (kid->op_type == OP_AELEM
7527 || kid->op_type == OP_HELEM)
7530 OP *op = ((BINOP*)kid)->op_first;
7534 const char * const a =
7535 kid->op_type == OP_AELEM ?
7537 if (((op->op_type == OP_RV2AV) ||
7538 (op->op_type == OP_RV2HV)) &&
7539 (firstop = ((UNOP*)op)->op_first) &&
7540 (firstop->op_type == OP_GV)) {
7541 /* packagevar $a[] or $h{} */
7542 GV * const gv = cGVOPx_gv(firstop);
7550 else if (op->op_type == OP_PADAV
7551 || op->op_type == OP_PADHV) {
7552 /* lexicalvar $a[] or $h{} */
7553 const char * const padname =
7554 PAD_COMPNAME_PV(op->op_targ);
7563 name = SvPV_const(tmpstr, len);
7568 name = "__ANONIO__";
7571 op_lvalue(kid, type);
7575 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7576 namesv = PAD_SVl(targ);
7577 SvUPGRADE(namesv, SVt_PV);
7579 sv_setpvs(namesv, "$");
7580 sv_catpvn(namesv, name, len);
7583 kid->op_sibling = 0;
7584 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7585 kid->op_targ = targ;
7586 kid->op_private |= priv;
7588 kid->op_sibling = sibl;
7594 op_lvalue(scalar(kid), type);
7598 tokid = &kid->op_sibling;
7599 kid = kid->op_sibling;
7602 if (kid && kid->op_type != OP_STUB)
7603 return too_many_arguments(o,OP_DESC(o));
7604 o->op_private |= numargs;
7606 /* FIXME - should the numargs move as for the PERL_MAD case? */
7607 o->op_private |= numargs;
7609 return too_many_arguments(o,OP_DESC(o));
7613 else if (PL_opargs[type] & OA_DEFGV) {
7615 OP *newop = newUNOP(type, 0, newDEFSVOP());
7616 op_getmad(o,newop,'O');
7619 /* Ordering of these two is important to keep f_map.t passing. */
7621 return newUNOP(type, 0, newDEFSVOP());
7626 while (oa & OA_OPTIONAL)
7628 if (oa && oa != OA_LIST)
7629 return too_few_arguments(o,OP_DESC(o));
7635 Perl_ck_glob(pTHX_ OP *o)
7640 PERL_ARGS_ASSERT_CK_GLOB;
7643 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7644 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7646 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7647 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7649 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7652 #if !defined(PERL_EXTERNAL_GLOB)
7653 /* XXX this can be tightened up and made more failsafe. */
7654 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7657 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7658 newSVpvs("File::Glob"), NULL, NULL, NULL);
7659 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7660 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7661 GvCV_set(gv, GvCV(glob_gv));
7662 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7663 GvIMPORTED_CV_on(gv);
7667 #endif /* PERL_EXTERNAL_GLOB */
7669 assert(!(o->op_flags & OPf_SPECIAL));
7670 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7673 * \ null - const(wildcard)
7678 * \ mark - glob - rv2cv
7679 * | \ gv(CORE::GLOBAL::glob)
7681 * \ null - const(wildcard) - const(ix)
7683 o->op_flags |= OPf_SPECIAL;
7684 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7685 op_append_elem(OP_GLOB, o,
7686 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7687 o = newLISTOP(OP_LIST, 0, o, NULL);
7688 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7689 op_append_elem(OP_LIST, o,
7690 scalar(newUNOP(OP_RV2CV, 0,
7691 newGVOP(OP_GV, 0, gv)))));
7692 o = newUNOP(OP_NULL, 0, ck_subr(o));
7693 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7696 gv = newGVgen("main");
7698 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7704 Perl_ck_grep(pTHX_ OP *o)
7709 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7712 PERL_ARGS_ASSERT_CK_GREP;
7714 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7715 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7717 if (o->op_flags & OPf_STACKED) {
7720 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7721 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7722 return no_fh_allowed(o);
7723 for (k = kid; k; k = k->op_next) {
7726 NewOp(1101, gwop, 1, LOGOP);
7727 kid->op_next = (OP*)gwop;
7728 o->op_flags &= ~OPf_STACKED;
7730 kid = cLISTOPo->op_first->op_sibling;
7731 if (type == OP_MAPWHILE)
7736 if (PL_parser && PL_parser->error_count)
7738 kid = cLISTOPo->op_first->op_sibling;
7739 if (kid->op_type != OP_NULL)
7740 Perl_croak(aTHX_ "panic: ck_grep");
7741 kid = kUNOP->op_first;
7744 NewOp(1101, gwop, 1, LOGOP);
7745 gwop->op_type = type;
7746 gwop->op_ppaddr = PL_ppaddr[type];
7747 gwop->op_first = listkids(o);
7748 gwop->op_flags |= OPf_KIDS;
7749 gwop->op_other = LINKLIST(kid);
7750 kid->op_next = (OP*)gwop;
7751 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7752 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7753 o->op_private = gwop->op_private = 0;
7754 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7757 o->op_private = gwop->op_private = OPpGREP_LEX;
7758 gwop->op_targ = o->op_targ = offset;
7761 kid = cLISTOPo->op_first->op_sibling;
7762 if (!kid || !kid->op_sibling)
7763 return too_few_arguments(o,OP_DESC(o));
7764 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7765 op_lvalue(kid, OP_GREPSTART);
7771 Perl_ck_index(pTHX_ OP *o)
7773 PERL_ARGS_ASSERT_CK_INDEX;
7775 if (o->op_flags & OPf_KIDS) {
7776 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7778 kid = kid->op_sibling; /* get past "big" */
7779 if (kid && kid->op_type == OP_CONST)
7780 fbm_compile(((SVOP*)kid)->op_sv, 0);
7786 Perl_ck_lfun(pTHX_ OP *o)
7788 const OPCODE type = o->op_type;
7790 PERL_ARGS_ASSERT_CK_LFUN;
7792 return modkids(ck_fun(o), type);
7796 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7798 PERL_ARGS_ASSERT_CK_DEFINED;
7800 if ((o->op_flags & OPf_KIDS)) {
7801 switch (cUNOPo->op_first->op_type) {
7803 /* This is needed for
7804 if (defined %stash::)
7805 to work. Do not break Tk.
7807 break; /* Globals via GV can be undef */
7809 case OP_AASSIGN: /* Is this a good idea? */
7810 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7811 "defined(@array) is deprecated");
7812 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7813 "\t(Maybe you should just omit the defined()?)\n");
7817 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7818 "defined(%%hash) is deprecated");
7819 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7820 "\t(Maybe you should just omit the defined()?)\n");
7831 Perl_ck_readline(pTHX_ OP *o)
7833 PERL_ARGS_ASSERT_CK_READLINE;
7835 if (!(o->op_flags & OPf_KIDS)) {
7837 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7839 op_getmad(o,newop,'O');
7849 Perl_ck_rfun(pTHX_ OP *o)
7851 const OPCODE type = o->op_type;
7853 PERL_ARGS_ASSERT_CK_RFUN;
7855 return refkids(ck_fun(o), type);
7859 Perl_ck_listiob(pTHX_ OP *o)
7863 PERL_ARGS_ASSERT_CK_LISTIOB;
7865 kid = cLISTOPo->op_first;
7868 kid = cLISTOPo->op_first;
7870 if (kid->op_type == OP_PUSHMARK)
7871 kid = kid->op_sibling;
7872 if (kid && o->op_flags & OPf_STACKED)
7873 kid = kid->op_sibling;
7874 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7875 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7876 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7877 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7878 cLISTOPo->op_first->op_sibling = kid;
7879 cLISTOPo->op_last = kid;
7880 kid = kid->op_sibling;
7885 op_append_elem(o->op_type, o, newDEFSVOP());
7891 Perl_ck_smartmatch(pTHX_ OP *o)
7894 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7895 if (0 == (o->op_flags & OPf_SPECIAL)) {
7896 OP *first = cBINOPo->op_first;
7897 OP *second = first->op_sibling;
7899 /* Implicitly take a reference to an array or hash */
7900 first->op_sibling = NULL;
7901 first = cBINOPo->op_first = ref_array_or_hash(first);
7902 second = first->op_sibling = ref_array_or_hash(second);
7904 /* Implicitly take a reference to a regular expression */
7905 if (first->op_type == OP_MATCH) {
7906 first->op_type = OP_QR;
7907 first->op_ppaddr = PL_ppaddr[OP_QR];
7909 if (second->op_type == OP_MATCH) {
7910 second->op_type = OP_QR;
7911 second->op_ppaddr = PL_ppaddr[OP_QR];
7920 Perl_ck_sassign(pTHX_ OP *o)
7923 OP * const kid = cLISTOPo->op_first;
7925 PERL_ARGS_ASSERT_CK_SASSIGN;
7927 /* has a disposable target? */
7928 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7929 && !(kid->op_flags & OPf_STACKED)
7930 /* Cannot steal the second time! */
7931 && !(kid->op_private & OPpTARGET_MY)
7932 /* Keep the full thing for madskills */
7936 OP * const kkid = kid->op_sibling;
7938 /* Can just relocate the target. */
7939 if (kkid && kkid->op_type == OP_PADSV
7940 && !(kkid->op_private & OPpLVAL_INTRO))
7942 kid->op_targ = kkid->op_targ;
7944 /* Now we do not need PADSV and SASSIGN. */
7945 kid->op_sibling = o->op_sibling; /* NULL */
7946 cLISTOPo->op_first = NULL;
7949 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7953 if (kid->op_sibling) {
7954 OP *kkid = kid->op_sibling;
7955 /* For state variable assignment, kkid is a list op whose op_last
7957 if ((kkid->op_type == OP_PADSV ||
7958 (kkid->op_type == OP_LIST &&
7959 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
7962 && (kkid->op_private & OPpLVAL_INTRO)
7963 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7964 const PADOFFSET target = kkid->op_targ;
7965 OP *const other = newOP(OP_PADSV,
7967 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7968 OP *const first = newOP(OP_NULL, 0);
7969 OP *const nullop = newCONDOP(0, first, o, other);
7970 OP *const condop = first->op_next;
7971 /* hijacking PADSTALE for uninitialized state variables */
7972 SvPADSTALE_on(PAD_SVl(target));
7974 condop->op_type = OP_ONCE;
7975 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7976 condop->op_targ = target;
7977 other->op_targ = target;
7979 /* Because we change the type of the op here, we will skip the
7980 assignment binop->op_last = binop->op_first->op_sibling; at the
7981 end of Perl_newBINOP(). So need to do it here. */
7982 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7991 Perl_ck_match(pTHX_ OP *o)
7995 PERL_ARGS_ASSERT_CK_MATCH;
7997 if (o->op_type != OP_QR && PL_compcv) {
7998 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7999 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8000 o->op_targ = offset;
8001 o->op_private |= OPpTARGET_MY;
8004 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8005 o->op_private |= OPpRUNTIME;
8010 Perl_ck_method(pTHX_ OP *o)
8012 OP * const kid = cUNOPo->op_first;
8014 PERL_ARGS_ASSERT_CK_METHOD;
8016 if (kid->op_type == OP_CONST) {
8017 SV* sv = kSVOP->op_sv;
8018 const char * const method = SvPVX_const(sv);
8019 if (!(strchr(method, ':') || strchr(method, '\''))) {
8021 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8022 sv = newSVpvn_share(method, SvCUR(sv), 0);
8025 kSVOP->op_sv = NULL;
8027 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8029 op_getmad(o,cmop,'O');
8040 Perl_ck_null(pTHX_ OP *o)
8042 PERL_ARGS_ASSERT_CK_NULL;
8043 PERL_UNUSED_CONTEXT;
8048 Perl_ck_open(pTHX_ OP *o)
8051 HV * const table = GvHV(PL_hintgv);
8053 PERL_ARGS_ASSERT_CK_OPEN;
8056 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8059 const char *d = SvPV_const(*svp, len);
8060 const I32 mode = mode_from_discipline(d, len);
8061 if (mode & O_BINARY)
8062 o->op_private |= OPpOPEN_IN_RAW;
8063 else if (mode & O_TEXT)
8064 o->op_private |= OPpOPEN_IN_CRLF;
8067 svp = hv_fetchs(table, "open_OUT", FALSE);
8070 const char *d = SvPV_const(*svp, len);
8071 const I32 mode = mode_from_discipline(d, len);
8072 if (mode & O_BINARY)
8073 o->op_private |= OPpOPEN_OUT_RAW;
8074 else if (mode & O_TEXT)
8075 o->op_private |= OPpOPEN_OUT_CRLF;
8078 if (o->op_type == OP_BACKTICK) {
8079 if (!(o->op_flags & OPf_KIDS)) {
8080 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8082 op_getmad(o,newop,'O');
8091 /* In case of three-arg dup open remove strictness
8092 * from the last arg if it is a bareword. */
8093 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8094 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8098 if ((last->op_type == OP_CONST) && /* The bareword. */
8099 (last->op_private & OPpCONST_BARE) &&
8100 (last->op_private & OPpCONST_STRICT) &&
8101 (oa = first->op_sibling) && /* The fh. */
8102 (oa = oa->op_sibling) && /* The mode. */
8103 (oa->op_type == OP_CONST) &&
8104 SvPOK(((SVOP*)oa)->op_sv) &&
8105 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8106 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8107 (last == oa->op_sibling)) /* The bareword. */
8108 last->op_private &= ~OPpCONST_STRICT;
8114 Perl_ck_repeat(pTHX_ OP *o)
8116 PERL_ARGS_ASSERT_CK_REPEAT;
8118 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8119 o->op_private |= OPpREPEAT_DOLIST;
8120 cBINOPo->op_first = force_list(cBINOPo->op_first);
8128 Perl_ck_require(pTHX_ OP *o)
8133 PERL_ARGS_ASSERT_CK_REQUIRE;
8135 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8136 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8138 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8139 SV * const sv = kid->op_sv;
8140 U32 was_readonly = SvREADONLY(sv);
8147 sv_force_normal_flags(sv, 0);
8148 assert(!SvREADONLY(sv));
8158 for (; s < end; s++) {
8159 if (*s == ':' && s[1] == ':') {
8161 Move(s+2, s+1, end - s - 1, char);
8166 sv_catpvs(sv, ".pm");
8167 SvFLAGS(sv) |= was_readonly;
8171 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8172 /* handle override, if any */
8173 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8174 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8175 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8176 gv = gvp ? *gvp : NULL;
8180 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8181 OP * const kid = cUNOPo->op_first;
8184 cUNOPo->op_first = 0;
8188 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8189 op_append_elem(OP_LIST, kid,
8190 scalar(newUNOP(OP_RV2CV, 0,
8193 op_getmad(o,newop,'O');
8197 return scalar(ck_fun(o));
8201 Perl_ck_return(pTHX_ OP *o)
8206 PERL_ARGS_ASSERT_CK_RETURN;
8208 kid = cLISTOPo->op_first->op_sibling;
8209 if (CvLVALUE(PL_compcv)) {
8210 for (; kid; kid = kid->op_sibling)
8211 op_lvalue(kid, OP_LEAVESUBLV);
8213 for (; kid; kid = kid->op_sibling)
8214 if ((kid->op_type == OP_NULL)
8215 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8216 /* This is a do block */
8217 OP *op = kUNOP->op_first;
8218 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8219 op = cUNOPx(op)->op_first;
8220 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8221 /* Force the use of the caller's context */
8222 op->op_flags |= OPf_SPECIAL;
8231 Perl_ck_select(pTHX_ OP *o)
8236 PERL_ARGS_ASSERT_CK_SELECT;
8238 if (o->op_flags & OPf_KIDS) {
8239 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8240 if (kid && kid->op_sibling) {
8241 o->op_type = OP_SSELECT;
8242 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8244 return fold_constants(o);
8248 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8249 if (kid && kid->op_type == OP_RV2GV)
8250 kid->op_private &= ~HINT_STRICT_REFS;
8255 Perl_ck_shift(pTHX_ OP *o)
8258 const I32 type = o->op_type;
8260 PERL_ARGS_ASSERT_CK_SHIFT;
8262 if (!(o->op_flags & OPf_KIDS)) {
8265 if (!CvUNIQUE(PL_compcv)) {
8266 o->op_flags |= OPf_SPECIAL;
8270 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8273 OP * const oldo = o;
8274 o = newUNOP(type, 0, scalar(argop));
8275 op_getmad(oldo,o,'O');
8280 return newUNOP(type, 0, scalar(argop));
8283 return scalar(ck_fun(o));
8287 Perl_ck_sort(pTHX_ OP *o)
8292 PERL_ARGS_ASSERT_CK_SORT;
8294 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8295 HV * const hinthv = GvHV(PL_hintgv);
8297 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8299 const I32 sorthints = (I32)SvIV(*svp);
8300 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8301 o->op_private |= OPpSORT_QSORT;
8302 if ((sorthints & HINT_SORT_STABLE) != 0)
8303 o->op_private |= OPpSORT_STABLE;
8308 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8310 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8311 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8313 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8315 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8317 if (kid->op_type == OP_SCOPE) {
8321 else if (kid->op_type == OP_LEAVE) {
8322 if (o->op_type == OP_SORT) {
8323 op_null(kid); /* wipe out leave */
8326 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8327 if (k->op_next == kid)
8329 /* don't descend into loops */
8330 else if (k->op_type == OP_ENTERLOOP
8331 || k->op_type == OP_ENTERITER)
8333 k = cLOOPx(k)->op_lastop;
8338 kid->op_next = 0; /* just disconnect the leave */
8339 k = kLISTOP->op_first;
8344 if (o->op_type == OP_SORT) {
8345 /* provide scalar context for comparison function/block */
8351 o->op_flags |= OPf_SPECIAL;
8353 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8356 firstkid = firstkid->op_sibling;
8359 /* provide list context for arguments */
8360 if (o->op_type == OP_SORT)
8367 S_simplify_sort(pTHX_ OP *o)
8370 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8376 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8378 if (!(o->op_flags & OPf_STACKED))
8380 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8381 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8382 kid = kUNOP->op_first; /* get past null */
8383 if (kid->op_type != OP_SCOPE)
8385 kid = kLISTOP->op_last; /* get past scope */
8386 switch(kid->op_type) {
8394 k = kid; /* remember this node*/
8395 if (kBINOP->op_first->op_type != OP_RV2SV)
8397 kid = kBINOP->op_first; /* get past cmp */
8398 if (kUNOP->op_first->op_type != OP_GV)
8400 kid = kUNOP->op_first; /* get past rv2sv */
8402 if (GvSTASH(gv) != PL_curstash)
8404 gvname = GvNAME(gv);
8405 if (*gvname == 'a' && gvname[1] == '\0')
8407 else if (*gvname == 'b' && gvname[1] == '\0')
8412 kid = k; /* back to cmp */
8413 if (kBINOP->op_last->op_type != OP_RV2SV)
8415 kid = kBINOP->op_last; /* down to 2nd arg */
8416 if (kUNOP->op_first->op_type != OP_GV)
8418 kid = kUNOP->op_first; /* get past rv2sv */
8420 if (GvSTASH(gv) != PL_curstash)
8422 gvname = GvNAME(gv);
8424 ? !(*gvname == 'a' && gvname[1] == '\0')
8425 : !(*gvname == 'b' && gvname[1] == '\0'))
8427 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8429 o->op_private |= OPpSORT_DESCEND;
8430 if (k->op_type == OP_NCMP)
8431 o->op_private |= OPpSORT_NUMERIC;
8432 if (k->op_type == OP_I_NCMP)
8433 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8434 kid = cLISTOPo->op_first->op_sibling;
8435 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8437 op_getmad(kid,o,'S'); /* then delete it */
8439 op_free(kid); /* then delete it */
8444 Perl_ck_split(pTHX_ OP *o)
8449 PERL_ARGS_ASSERT_CK_SPLIT;
8451 if (o->op_flags & OPf_STACKED)
8452 return no_fh_allowed(o);
8454 kid = cLISTOPo->op_first;
8455 if (kid->op_type != OP_NULL)
8456 Perl_croak(aTHX_ "panic: ck_split");
8457 kid = kid->op_sibling;
8458 op_free(cLISTOPo->op_first);
8460 cLISTOPo->op_first = kid;
8462 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8463 cLISTOPo->op_last = kid; /* There was only one element previously */
8466 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8467 OP * const sibl = kid->op_sibling;
8468 kid->op_sibling = 0;
8469 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8470 if (cLISTOPo->op_first == cLISTOPo->op_last)
8471 cLISTOPo->op_last = kid;
8472 cLISTOPo->op_first = kid;
8473 kid->op_sibling = sibl;
8476 kid->op_type = OP_PUSHRE;
8477 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8479 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8480 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8481 "Use of /g modifier is meaningless in split");
8484 if (!kid->op_sibling)
8485 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8487 kid = kid->op_sibling;
8490 if (!kid->op_sibling)
8491 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8492 assert(kid->op_sibling);
8494 kid = kid->op_sibling;
8497 if (kid->op_sibling)
8498 return too_many_arguments(o,OP_DESC(o));
8504 Perl_ck_join(pTHX_ OP *o)
8506 const OP * const kid = cLISTOPo->op_first->op_sibling;
8508 PERL_ARGS_ASSERT_CK_JOIN;
8510 if (kid && kid->op_type == OP_MATCH) {
8511 if (ckWARN(WARN_SYNTAX)) {
8512 const REGEXP *re = PM_GETRE(kPMOP);
8513 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8514 const STRLEN len = re ? RX_PRELEN(re) : 6;
8515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8516 "/%.*s/ should probably be written as \"%.*s\"",
8517 (int)len, pmstr, (int)len, pmstr);
8524 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8526 Examines an op, which is expected to identify a subroutine at runtime,
8527 and attempts to determine at compile time which subroutine it identifies.
8528 This is normally used during Perl compilation to determine whether
8529 a prototype can be applied to a function call. I<cvop> is the op
8530 being considered, normally an C<rv2cv> op. A pointer to the identified
8531 subroutine is returned, if it could be determined statically, and a null
8532 pointer is returned if it was not possible to determine statically.
8534 Currently, the subroutine can be identified statically if the RV that the
8535 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8536 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8537 suitable if the constant value must be an RV pointing to a CV. Details of
8538 this process may change in future versions of Perl. If the C<rv2cv> op
8539 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8540 the subroutine statically: this flag is used to suppress compile-time
8541 magic on a subroutine call, forcing it to use default runtime behaviour.
8543 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8544 of a GV reference is modified. If a GV was examined and its CV slot was
8545 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8546 If the op is not optimised away, and the CV slot is later populated with
8547 a subroutine having a prototype, that flag eventually triggers the warning
8548 "called too early to check prototype".
8550 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8551 of returning a pointer to the subroutine it returns a pointer to the
8552 GV giving the most appropriate name for the subroutine in this context.
8553 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8554 (C<CvANON>) subroutine that is referenced through a GV it will be the
8555 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8556 A null pointer is returned as usual if there is no statically-determinable
8563 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8568 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8569 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8570 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8571 if (cvop->op_type != OP_RV2CV)
8573 if (cvop->op_private & OPpENTERSUB_AMPER)
8575 if (!(cvop->op_flags & OPf_KIDS))
8577 rvop = cUNOPx(cvop)->op_first;
8578 switch (rvop->op_type) {
8580 gv = cGVOPx_gv(rvop);
8583 if (flags & RV2CVOPCV_MARK_EARLY)
8584 rvop->op_private |= OPpEARLY_CV;
8589 SV *rv = cSVOPx_sv(rvop);
8599 if (SvTYPE((SV*)cv) != SVt_PVCV)
8601 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8602 if (!CvANON(cv) || !gv)
8611 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8613 Performs the default fixup of the arguments part of an C<entersub>
8614 op tree. This consists of applying list context to each of the
8615 argument ops. This is the standard treatment used on a call marked
8616 with C<&>, or a method call, or a call through a subroutine reference,
8617 or any other call where the callee can't be identified at compile time,
8618 or a call where the callee has no prototype.
8624 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8627 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8628 aop = cUNOPx(entersubop)->op_first;
8629 if (!aop->op_sibling)
8630 aop = cUNOPx(aop)->op_first;
8631 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8632 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8634 op_lvalue(aop, OP_ENTERSUB);
8641 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8643 Performs the fixup of the arguments part of an C<entersub> op tree
8644 based on a subroutine prototype. This makes various modifications to
8645 the argument ops, from applying context up to inserting C<refgen> ops,
8646 and checking the number and syntactic types of arguments, as directed by
8647 the prototype. This is the standard treatment used on a subroutine call,
8648 not marked with C<&>, where the callee can be identified at compile time
8649 and has a prototype.
8651 I<protosv> supplies the subroutine prototype to be applied to the call.
8652 It may be a normal defined scalar, of which the string value will be used.
8653 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8654 that has been cast to C<SV*>) which has a prototype. The prototype
8655 supplied, in whichever form, does not need to match the actual callee
8656 referenced by the op tree.
8658 If the argument ops disagree with the prototype, for example by having
8659 an unacceptable number of arguments, a valid op tree is returned anyway.
8660 The error is reflected in the parser state, normally resulting in a single
8661 exception at the top level of parsing which covers all the compilation
8662 errors that occurred. In the error message, the callee is referred to
8663 by the name defined by the I<namegv> parameter.
8669 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8672 const char *proto, *proto_end;
8673 OP *aop, *prev, *cvop;
8676 I32 contextclass = 0;
8677 const char *e = NULL;
8678 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8679 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8680 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8681 proto = SvPV(protosv, proto_len);
8682 proto_end = proto + proto_len;
8683 aop = cUNOPx(entersubop)->op_first;
8684 if (!aop->op_sibling)
8685 aop = cUNOPx(aop)->op_first;
8687 aop = aop->op_sibling;
8688 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8689 while (aop != cvop) {
8691 if (PL_madskills && aop->op_type == OP_STUB) {
8692 aop = aop->op_sibling;
8695 if (PL_madskills && aop->op_type == OP_NULL)
8696 o3 = ((UNOP*)aop)->op_first;
8700 if (proto >= proto_end)
8701 return too_many_arguments(entersubop, gv_ename(namegv));
8709 /* _ must be at the end */
8710 if (proto[1] && proto[1] != ';')
8725 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8727 arg == 1 ? "block or sub {}" : "sub {}",
8728 gv_ename(namegv), o3);
8731 /* '*' allows any scalar type, including bareword */
8734 if (o3->op_type == OP_RV2GV)
8735 goto wrapref; /* autoconvert GLOB -> GLOBref */
8736 else if (o3->op_type == OP_CONST)
8737 o3->op_private &= ~OPpCONST_STRICT;
8738 else if (o3->op_type == OP_ENTERSUB) {
8739 /* accidental subroutine, revert to bareword */
8740 OP *gvop = ((UNOP*)o3)->op_first;
8741 if (gvop && gvop->op_type == OP_NULL) {
8742 gvop = ((UNOP*)gvop)->op_first;
8744 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8747 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8748 (gvop = ((UNOP*)gvop)->op_first) &&
8749 gvop->op_type == OP_GV)
8751 GV * const gv = cGVOPx_gv(gvop);
8752 OP * const sibling = aop->op_sibling;
8753 SV * const n = newSVpvs("");
8755 OP * const oldaop = aop;
8759 gv_fullname4(n, gv, "", FALSE);
8760 aop = newSVOP(OP_CONST, 0, n);
8761 op_getmad(oldaop,aop,'O');
8762 prev->op_sibling = aop;
8763 aop->op_sibling = sibling;
8773 if (o3->op_type == OP_RV2AV ||
8774 o3->op_type == OP_PADAV ||
8775 o3->op_type == OP_RV2HV ||
8776 o3->op_type == OP_PADHV
8791 if (contextclass++ == 0) {
8792 e = strchr(proto, ']');
8793 if (!e || e == proto)
8802 const char *p = proto;
8803 const char *const end = proto;
8805 while (*--p != '[') {}
8806 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8808 gv_ename(namegv), o3);
8813 if (o3->op_type == OP_RV2GV)
8816 bad_type(arg, "symbol", gv_ename(namegv), o3);
8819 if (o3->op_type == OP_ENTERSUB)
8822 bad_type(arg, "subroutine entry", gv_ename(namegv),
8826 if (o3->op_type == OP_RV2SV ||
8827 o3->op_type == OP_PADSV ||
8828 o3->op_type == OP_HELEM ||
8829 o3->op_type == OP_AELEM)
8832 bad_type(arg, "scalar", gv_ename(namegv), o3);
8835 if (o3->op_type == OP_RV2AV ||
8836 o3->op_type == OP_PADAV)
8839 bad_type(arg, "array", gv_ename(namegv), o3);
8842 if (o3->op_type == OP_RV2HV ||
8843 o3->op_type == OP_PADHV)
8846 bad_type(arg, "hash", gv_ename(namegv), o3);
8850 OP* const kid = aop;
8851 OP* const sib = kid->op_sibling;
8852 kid->op_sibling = 0;
8853 aop = newUNOP(OP_REFGEN, 0, kid);
8854 aop->op_sibling = sib;
8855 prev->op_sibling = aop;
8857 if (contextclass && e) {
8872 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8873 gv_ename(namegv), SVfARG(protosv));
8876 op_lvalue(aop, OP_ENTERSUB);
8878 aop = aop->op_sibling;
8880 if (aop == cvop && *proto == '_') {
8881 /* generate an access to $_ */
8883 aop->op_sibling = prev->op_sibling;
8884 prev->op_sibling = aop; /* instead of cvop */
8886 if (!optional && proto_end > proto &&
8887 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8888 return too_few_arguments(entersubop, gv_ename(namegv));
8893 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8895 Performs the fixup of the arguments part of an C<entersub> op tree either
8896 based on a subroutine prototype or using default list-context processing.
8897 This is the standard treatment used on a subroutine call, not marked
8898 with C<&>, where the callee can be identified at compile time.
8900 I<protosv> supplies the subroutine prototype to be applied to the call,
8901 or indicates that there is no prototype. It may be a normal scalar,
8902 in which case if it is defined then the string value will be used
8903 as a prototype, and if it is undefined then there is no prototype.
8904 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8905 that has been cast to C<SV*>), of which the prototype will be used if it
8906 has one. The prototype (or lack thereof) supplied, in whichever form,
8907 does not need to match the actual callee referenced by the op tree.
8909 If the argument ops disagree with the prototype, for example by having
8910 an unacceptable number of arguments, a valid op tree is returned anyway.
8911 The error is reflected in the parser state, normally resulting in a single
8912 exception at the top level of parsing which covers all the compilation
8913 errors that occurred. In the error message, the callee is referred to
8914 by the name defined by the I<namegv> parameter.
8920 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8921 GV *namegv, SV *protosv)
8923 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8924 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8925 return ck_entersub_args_proto(entersubop, namegv, protosv);
8927 return ck_entersub_args_list(entersubop);
8931 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8933 Retrieves the function that will be used to fix up a call to I<cv>.
8934 Specifically, the function is applied to an C<entersub> op tree for a
8935 subroutine call, not marked with C<&>, where the callee can be identified
8936 at compile time as I<cv>.
8938 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8939 argument for it is returned in I<*ckobj_p>. The function is intended
8940 to be called in this manner:
8942 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8944 In this call, I<entersubop> is a pointer to the C<entersub> op,
8945 which may be replaced by the check function, and I<namegv> is a GV
8946 supplying the name that should be used by the check function to refer
8947 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8948 It is permitted to apply the check function in non-standard situations,
8949 such as to a call to a different subroutine or to a method call.
8951 By default, the function is
8952 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8953 and the SV parameter is I<cv> itself. This implements standard
8954 prototype processing. It can be changed, for a particular subroutine,
8955 by L</cv_set_call_checker>.
8961 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8964 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8965 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8967 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8968 *ckobj_p = callmg->mg_obj;
8970 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8976 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8978 Sets the function that will be used to fix up a call to I<cv>.
8979 Specifically, the function is applied to an C<entersub> op tree for a
8980 subroutine call, not marked with C<&>, where the callee can be identified
8981 at compile time as I<cv>.
8983 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8984 for it is supplied in I<ckobj>. The function is intended to be called
8987 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8989 In this call, I<entersubop> is a pointer to the C<entersub> op,
8990 which may be replaced by the check function, and I<namegv> is a GV
8991 supplying the name that should be used by the check function to refer
8992 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8993 It is permitted to apply the check function in non-standard situations,
8994 such as to a call to a different subroutine or to a method call.
8996 The current setting for a particular CV can be retrieved by
8997 L</cv_get_call_checker>.
9003 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9005 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9006 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9007 if (SvMAGICAL((SV*)cv))
9008 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9011 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9012 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9013 if (callmg->mg_flags & MGf_REFCOUNTED) {
9014 SvREFCNT_dec(callmg->mg_obj);
9015 callmg->mg_flags &= ~MGf_REFCOUNTED;
9017 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9018 callmg->mg_obj = ckobj;
9019 if (ckobj != (SV*)cv) {
9020 SvREFCNT_inc_simple_void_NN(ckobj);
9021 callmg->mg_flags |= MGf_REFCOUNTED;
9027 Perl_ck_subr(pTHX_ OP *o)
9033 PERL_ARGS_ASSERT_CK_SUBR;
9035 aop = cUNOPx(o)->op_first;
9036 if (!aop->op_sibling)
9037 aop = cUNOPx(aop)->op_first;
9038 aop = aop->op_sibling;
9039 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9040 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9041 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9043 o->op_private |= OPpENTERSUB_HASTARG;
9044 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9045 if (PERLDB_SUB && PL_curstash != PL_debstash)
9046 o->op_private |= OPpENTERSUB_DB;
9047 if (cvop->op_type == OP_RV2CV) {
9048 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9050 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9051 if (aop->op_type == OP_CONST)
9052 aop->op_private &= ~OPpCONST_STRICT;
9053 else if (aop->op_type == OP_LIST) {
9054 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9055 if (sib && sib->op_type == OP_CONST)
9056 sib->op_private &= ~OPpCONST_STRICT;
9061 return ck_entersub_args_list(o);
9063 Perl_call_checker ckfun;
9065 cv_get_call_checker(cv, &ckfun, &ckobj);
9066 return ckfun(aTHX_ o, namegv, ckobj);
9071 Perl_ck_svconst(pTHX_ OP *o)
9073 PERL_ARGS_ASSERT_CK_SVCONST;
9074 PERL_UNUSED_CONTEXT;
9075 SvREADONLY_on(cSVOPo->op_sv);
9080 Perl_ck_chdir(pTHX_ OP *o)
9082 PERL_ARGS_ASSERT_CK_CHDIR;
9083 if (o->op_flags & OPf_KIDS) {
9084 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9086 if (kid && kid->op_type == OP_CONST &&
9087 (kid->op_private & OPpCONST_BARE))
9089 o->op_flags |= OPf_SPECIAL;
9090 kid->op_private &= ~OPpCONST_STRICT;
9097 Perl_ck_trunc(pTHX_ OP *o)
9099 PERL_ARGS_ASSERT_CK_TRUNC;
9101 if (o->op_flags & OPf_KIDS) {
9102 SVOP *kid = (SVOP*)cUNOPo->op_first;
9104 if (kid->op_type == OP_NULL)
9105 kid = (SVOP*)kid->op_sibling;
9106 if (kid && kid->op_type == OP_CONST &&
9107 (kid->op_private & OPpCONST_BARE))
9109 o->op_flags |= OPf_SPECIAL;
9110 kid->op_private &= ~OPpCONST_STRICT;
9117 Perl_ck_unpack(pTHX_ OP *o)
9119 OP *kid = cLISTOPo->op_first;
9121 PERL_ARGS_ASSERT_CK_UNPACK;
9123 if (kid->op_sibling) {
9124 kid = kid->op_sibling;
9125 if (!kid->op_sibling)
9126 kid->op_sibling = newDEFSVOP();
9132 Perl_ck_substr(pTHX_ OP *o)
9134 PERL_ARGS_ASSERT_CK_SUBSTR;
9137 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9138 OP *kid = cLISTOPo->op_first;
9140 if (kid->op_type == OP_NULL)
9141 kid = kid->op_sibling;
9143 kid->op_flags |= OPf_MOD;
9150 Perl_ck_each(pTHX_ OP *o)
9153 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9154 const unsigned orig_type = o->op_type;
9155 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9156 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9157 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9158 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9160 PERL_ARGS_ASSERT_CK_EACH;
9163 switch (kid->op_type) {
9169 CHANGE_TYPE(o, array_type);
9172 if (kid->op_private == OPpCONST_BARE
9173 || !SvROK(cSVOPx_sv(kid))
9174 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9175 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9177 /* we let ck_fun handle it */
9180 CHANGE_TYPE(o, ref_type);
9184 /* if treating as a reference, defer additional checks to runtime */
9185 return o->op_type == ref_type ? o : ck_fun(o);
9188 /* caller is supposed to assign the return to the
9189 container of the rep_op var */
9191 S_opt_scalarhv(pTHX_ OP *rep_op) {
9195 PERL_ARGS_ASSERT_OPT_SCALARHV;
9197 NewOp(1101, unop, 1, UNOP);
9198 unop->op_type = (OPCODE)OP_BOOLKEYS;
9199 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9200 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9201 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9202 unop->op_first = rep_op;
9203 unop->op_next = rep_op->op_next;
9204 rep_op->op_next = (OP*)unop;
9205 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9206 unop->op_sibling = rep_op->op_sibling;
9207 rep_op->op_sibling = NULL;
9208 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9209 if (rep_op->op_type == OP_PADHV) {
9210 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9211 rep_op->op_flags |= OPf_WANT_LIST;
9216 /* Checks if o acts as an in-place operator on an array. oright points to the
9217 * beginning of the right-hand side. Returns the left-hand side of the
9218 * assignment if o acts in-place, or NULL otherwise. */
9221 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9225 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9228 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9229 || oright->op_next != o
9230 || (oright->op_private & OPpLVAL_INTRO)
9234 /* o2 follows the chain of op_nexts through the LHS of the
9235 * assign (if any) to the aassign op itself */
9237 if (!o2 || o2->op_type != OP_NULL)
9240 if (!o2 || o2->op_type != OP_PUSHMARK)
9243 if (o2 && o2->op_type == OP_GV)
9246 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9247 || (o2->op_private & OPpLVAL_INTRO)
9252 if (!o2 || o2->op_type != OP_NULL)
9255 if (!o2 || o2->op_type != OP_AASSIGN
9256 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9259 /* check that the sort is the first arg on RHS of assign */
9261 o2 = cUNOPx(o2)->op_first;
9262 if (!o2 || o2->op_type != OP_NULL)
9264 o2 = cUNOPx(o2)->op_first;
9265 if (!o2 || o2->op_type != OP_PUSHMARK)
9267 if (o2->op_sibling != o)
9270 /* check the array is the same on both sides */
9271 if (oleft->op_type == OP_RV2AV) {
9272 if (oright->op_type != OP_RV2AV
9273 || !cUNOPx(oright)->op_first
9274 || cUNOPx(oright)->op_first->op_type != OP_GV
9275 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9276 cGVOPx_gv(cUNOPx(oright)->op_first)
9280 else if (oright->op_type != OP_PADAV
9281 || oright->op_targ != oleft->op_targ
9288 /* A peephole optimizer. We visit the ops in the order they're to execute.
9289 * See the comments at the top of this file for more details about when
9290 * peep() is called */
9293 Perl_rpeep(pTHX_ register OP *o)
9296 register OP* oldop = NULL;
9298 if (!o || o->op_opt)
9302 SAVEVPTR(PL_curcop);
9303 for (; o; o = o->op_next) {
9304 #if defined(PERL_MAD) && defined(USE_ITHREADS)
9305 MADPROP *mp = o->op_madprop;
9307 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
9308 OP *prop_op = (OP *) mp->mad_val;
9309 /* I *think* that this is roughly the right thing to do. It
9310 seems that sometimes the optree hooked into the madprops
9311 doesn't have its next pointers set, so it's not possible to
9312 use them to locate all the OPs needing a fixup. Possibly
9313 it's a bit overkill calling LINKLIST to do this, when we
9314 could instead iterate over the OPs (without changing them)
9315 the way op_linklist does internally. However, I'm not sure
9316 if there are corner cases where we have a chain of partially
9317 linked OPs. Or even if we do, does that matter? Or should
9318 we always iterate on op_first,op_next? */
9321 if (prop_op->op_opt)
9323 prop_op->op_opt = 1;
9324 switch (prop_op->op_type) {
9327 case OP_METHOD_NAMED:
9328 /* Duplicate the "relocate sv to the pad for thread
9329 safety" code, as otherwise an opfree of this madprop
9330 in the wrong thread will free the SV to the wrong
9332 if (((SVOP *)prop_op)->op_sv) {
9333 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9334 sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
9335 SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
9336 ((SVOP *)prop_op)->op_sv = NULL;
9340 } while ((prop_op = prop_op->op_next));
9347 /* By default, this op has now been optimised. A couple of cases below
9348 clear this again. */
9351 switch (o->op_type) {
9353 PL_curcop = ((COP*)o); /* for warnings */
9356 PL_curcop = ((COP*)o); /* for warnings */
9358 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9359 to carry two labels. For now, take the easier option, and skip
9360 this optimisation if the first NEXTSTATE has a label. */
9361 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9362 OP *nextop = o->op_next;
9363 while (nextop && nextop->op_type == OP_NULL)
9364 nextop = nextop->op_next;
9366 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9367 COP *firstcop = (COP *)o;
9368 COP *secondcop = (COP *)nextop;
9369 /* We want the COP pointed to by o (and anything else) to
9370 become the next COP down the line. */
9373 firstcop->op_next = secondcop->op_next;
9375 /* Now steal all its pointers, and duplicate the other
9377 firstcop->cop_line = secondcop->cop_line;
9379 firstcop->cop_stashpv = secondcop->cop_stashpv;
9380 firstcop->cop_file = secondcop->cop_file;
9382 firstcop->cop_stash = secondcop->cop_stash;
9383 firstcop->cop_filegv = secondcop->cop_filegv;
9385 firstcop->cop_hints = secondcop->cop_hints;
9386 firstcop->cop_seq = secondcop->cop_seq;
9387 firstcop->cop_warnings = secondcop->cop_warnings;
9388 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9391 secondcop->cop_stashpv = NULL;
9392 secondcop->cop_file = NULL;
9394 secondcop->cop_stash = NULL;
9395 secondcop->cop_filegv = NULL;
9397 secondcop->cop_warnings = NULL;
9398 secondcop->cop_hints_hash = NULL;
9400 /* If we use op_null(), and hence leave an ex-COP, some
9401 warnings are misreported. For example, the compile-time
9402 error in 'use strict; no strict refs;' */
9403 secondcop->op_type = OP_NULL;
9404 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9410 if (cSVOPo->op_private & OPpCONST_STRICT)
9411 no_bareword_allowed(o);
9414 case OP_METHOD_NAMED:
9415 /* Relocate sv to the pad for thread safety.
9416 * Despite being a "constant", the SV is written to,
9417 * for reference counts, sv_upgrade() etc. */
9419 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9420 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9421 /* If op_sv is already a PADTMP then it is being used by
9422 * some pad, so make a copy. */
9423 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9424 SvREADONLY_on(PAD_SVl(ix));
9425 SvREFCNT_dec(cSVOPo->op_sv);
9427 else if (o->op_type != OP_METHOD_NAMED
9428 && cSVOPo->op_sv == &PL_sv_undef) {
9429 /* PL_sv_undef is hack - it's unsafe to store it in the
9430 AV that is the pad, because av_fetch treats values of
9431 PL_sv_undef as a "free" AV entry and will merrily
9432 replace them with a new SV, causing pad_alloc to think
9433 that this pad slot is free. (When, clearly, it is not)
9435 SvOK_off(PAD_SVl(ix));
9436 SvPADTMP_on(PAD_SVl(ix));
9437 SvREADONLY_on(PAD_SVl(ix));
9440 SvREFCNT_dec(PAD_SVl(ix));
9441 SvPADTMP_on(cSVOPo->op_sv);
9442 PAD_SETSV(ix, cSVOPo->op_sv);
9443 /* XXX I don't know how this isn't readonly already. */
9444 SvREADONLY_on(PAD_SVl(ix));
9446 cSVOPo->op_sv = NULL;
9453 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9454 if (o->op_next->op_private & OPpTARGET_MY) {
9455 if (o->op_flags & OPf_STACKED) /* chained concats */
9456 break; /* ignore_optimization */
9458 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9459 o->op_targ = o->op_next->op_targ;
9460 o->op_next->op_targ = 0;
9461 o->op_private |= OPpTARGET_MY;
9464 op_null(o->op_next);
9468 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9469 break; /* Scalar stub must produce undef. List stub is noop */
9473 if (o->op_targ == OP_NEXTSTATE
9474 || o->op_targ == OP_DBSTATE)
9476 PL_curcop = ((COP*)o);
9478 /* XXX: We avoid setting op_seq here to prevent later calls
9479 to rpeep() from mistakenly concluding that optimisation
9480 has already occurred. This doesn't fix the real problem,
9481 though (See 20010220.007). AMS 20010719 */
9482 /* op_seq functionality is now replaced by op_opt */
9489 if (oldop && o->op_next) {
9490 oldop->op_next = o->op_next;
9498 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9499 OP* const pop = (o->op_type == OP_PADAV) ?
9500 o->op_next : o->op_next->op_next;
9502 if (pop && pop->op_type == OP_CONST &&
9503 ((PL_op = pop->op_next)) &&
9504 pop->op_next->op_type == OP_AELEM &&
9505 !(pop->op_next->op_private &
9506 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9507 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9512 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9513 no_bareword_allowed(pop);
9514 if (o->op_type == OP_GV)
9515 op_null(o->op_next);
9516 op_null(pop->op_next);
9518 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9519 o->op_next = pop->op_next->op_next;
9520 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9521 o->op_private = (U8)i;
9522 if (o->op_type == OP_GV) {
9527 o->op_flags |= OPf_SPECIAL;
9528 o->op_type = OP_AELEMFAST;
9533 if (o->op_next->op_type == OP_RV2SV) {
9534 if (!(o->op_next->op_private & OPpDEREF)) {
9535 op_null(o->op_next);
9536 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9538 o->op_next = o->op_next->op_next;
9539 o->op_type = OP_GVSV;
9540 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9543 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9544 GV * const gv = cGVOPo_gv;
9545 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9546 /* XXX could check prototype here instead of just carping */
9547 SV * const sv = sv_newmortal();
9548 gv_efullname3(sv, gv, NULL);
9549 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9550 "%"SVf"() called too early to check prototype",
9554 else if (o->op_next->op_type == OP_READLINE
9555 && o->op_next->op_next->op_type == OP_CONCAT
9556 && (o->op_next->op_next->op_flags & OPf_STACKED))
9558 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9559 o->op_type = OP_RCATLINE;
9560 o->op_flags |= OPf_STACKED;
9561 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9562 op_null(o->op_next->op_next);
9563 op_null(o->op_next);
9573 fop = cUNOP->op_first;
9581 fop = cLOGOP->op_first;
9582 sop = fop->op_sibling;
9583 while (cLOGOP->op_other->op_type == OP_NULL)
9584 cLOGOP->op_other = cLOGOP->op_other->op_next;
9585 CALL_RPEEP(cLOGOP->op_other);
9589 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9591 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9596 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9597 while (nop && nop->op_next) {
9598 switch (nop->op_next->op_type) {
9603 lop = nop = nop->op_next;
9614 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9615 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9616 cLOGOP->op_first = opt_scalarhv(fop);
9617 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9618 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9634 while (cLOGOP->op_other->op_type == OP_NULL)
9635 cLOGOP->op_other = cLOGOP->op_other->op_next;
9636 CALL_RPEEP(cLOGOP->op_other);
9641 while (cLOOP->op_redoop->op_type == OP_NULL)
9642 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9643 CALL_RPEEP(cLOOP->op_redoop);
9644 while (cLOOP->op_nextop->op_type == OP_NULL)
9645 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9646 CALL_RPEEP(cLOOP->op_nextop);
9647 while (cLOOP->op_lastop->op_type == OP_NULL)
9648 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9649 CALL_RPEEP(cLOOP->op_lastop);
9653 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9654 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9655 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9656 cPMOP->op_pmstashstartu.op_pmreplstart
9657 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9658 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9662 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9663 && ckWARN(WARN_SYNTAX))
9665 if (o->op_next->op_sibling) {
9666 const OPCODE type = o->op_next->op_sibling->op_type;
9667 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9668 const line_t oldline = CopLINE(PL_curcop);
9669 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9670 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9671 "Statement unlikely to be reached");
9672 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9673 "\t(Maybe you meant system() when you said exec()?)\n");
9674 CopLINE_set(PL_curcop, oldline);
9685 const char *key = NULL;
9688 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9691 /* Make the CONST have a shared SV */
9692 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9693 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9694 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9695 key = SvPV_const(sv, keylen);
9696 lexname = newSVpvn_share(key,
9697 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9703 if ((o->op_private & (OPpLVAL_INTRO)))
9706 rop = (UNOP*)((BINOP*)o)->op_first;
9707 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9709 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9710 if (!SvPAD_TYPED(lexname))
9712 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9713 if (!fields || !GvHV(*fields))
9715 key = SvPV_const(*svp, keylen);
9716 if (!hv_fetch(GvHV(*fields), key,
9717 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9719 Perl_croak(aTHX_ "No such class field \"%s\" "
9720 "in variable %s of type %s",
9721 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9734 SVOP *first_key_op, *key_op;
9736 if ((o->op_private & (OPpLVAL_INTRO))
9737 /* I bet there's always a pushmark... */
9738 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9739 /* hmmm, no optimization if list contains only one key. */
9741 rop = (UNOP*)((LISTOP*)o)->op_last;
9742 if (rop->op_type != OP_RV2HV)
9744 if (rop->op_first->op_type == OP_PADSV)
9745 /* @$hash{qw(keys here)} */
9746 rop = (UNOP*)rop->op_first;
9748 /* @{$hash}{qw(keys here)} */
9749 if (rop->op_first->op_type == OP_SCOPE
9750 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9752 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9758 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9759 if (!SvPAD_TYPED(lexname))
9761 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9762 if (!fields || !GvHV(*fields))
9764 /* Again guessing that the pushmark can be jumped over.... */
9765 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9766 ->op_first->op_sibling;
9767 for (key_op = first_key_op; key_op;
9768 key_op = (SVOP*)key_op->op_sibling) {
9769 if (key_op->op_type != OP_CONST)
9771 svp = cSVOPx_svp(key_op);
9772 key = SvPV_const(*svp, keylen);
9773 if (!hv_fetch(GvHV(*fields), key,
9774 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9776 Perl_croak(aTHX_ "No such class field \"%s\" "
9777 "in variable %s of type %s",
9778 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9787 && ( oldop->op_type == OP_AELEM
9788 || oldop->op_type == OP_PADSV
9789 || oldop->op_type == OP_RV2SV
9790 || oldop->op_type == OP_RV2GV
9791 || oldop->op_type == OP_HELEM
9793 && (oldop->op_private & OPpDEREF)
9795 o->op_private |= OPpDEREFed;
9799 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9803 /* check that RHS of sort is a single plain array */
9804 OP *oright = cUNOPo->op_first;
9805 if (!oright || oright->op_type != OP_PUSHMARK)
9808 /* reverse sort ... can be optimised. */
9809 if (!cUNOPo->op_sibling) {
9810 /* Nothing follows us on the list. */
9811 OP * const reverse = o->op_next;
9813 if (reverse->op_type == OP_REVERSE &&
9814 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9815 OP * const pushmark = cUNOPx(reverse)->op_first;
9816 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9817 && (cUNOPx(pushmark)->op_sibling == o)) {
9818 /* reverse -> pushmark -> sort */
9819 o->op_private |= OPpSORT_REVERSE;
9821 pushmark->op_next = oright->op_next;
9827 /* make @a = sort @a act in-place */
9829 oright = cUNOPx(oright)->op_sibling;
9832 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9833 oright = cUNOPx(oright)->op_sibling;
9836 oleft = is_inplace_av(o, oright);
9840 /* transfer MODishness etc from LHS arg to RHS arg */
9841 oright->op_flags = oleft->op_flags;
9842 o->op_private |= OPpSORT_INPLACE;
9844 /* excise push->gv->rv2av->null->aassign */
9845 o2 = o->op_next->op_next;
9846 op_null(o2); /* PUSHMARK */
9848 if (o2->op_type == OP_GV) {
9849 op_null(o2); /* GV */
9852 op_null(o2); /* RV2AV or PADAV */
9853 o2 = o2->op_next->op_next;
9854 op_null(o2); /* AASSIGN */
9856 o->op_next = o2->op_next;
9862 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9865 LISTOP *enter, *exlist;
9867 /* @a = reverse @a */
9868 if ((oright = cLISTOPo->op_first)
9869 && (oright->op_type == OP_PUSHMARK)
9870 && (oright = oright->op_sibling)
9871 && (oleft = is_inplace_av(o, oright))) {
9874 /* transfer MODishness etc from LHS arg to RHS arg */
9875 oright->op_flags = oleft->op_flags;
9876 o->op_private |= OPpREVERSE_INPLACE;
9878 /* excise push->gv->rv2av->null->aassign */
9879 o2 = o->op_next->op_next;
9880 op_null(o2); /* PUSHMARK */
9882 if (o2->op_type == OP_GV) {
9883 op_null(o2); /* GV */
9886 op_null(o2); /* RV2AV or PADAV */
9887 o2 = o2->op_next->op_next;
9888 op_null(o2); /* AASSIGN */
9890 o->op_next = o2->op_next;
9894 enter = (LISTOP *) o->op_next;
9897 if (enter->op_type == OP_NULL) {
9898 enter = (LISTOP *) enter->op_next;
9902 /* for $a (...) will have OP_GV then OP_RV2GV here.
9903 for (...) just has an OP_GV. */
9904 if (enter->op_type == OP_GV) {
9905 gvop = (OP *) enter;
9906 enter = (LISTOP *) enter->op_next;
9909 if (enter->op_type == OP_RV2GV) {
9910 enter = (LISTOP *) enter->op_next;
9916 if (enter->op_type != OP_ENTERITER)
9919 iter = enter->op_next;
9920 if (!iter || iter->op_type != OP_ITER)
9923 expushmark = enter->op_first;
9924 if (!expushmark || expushmark->op_type != OP_NULL
9925 || expushmark->op_targ != OP_PUSHMARK)
9928 exlist = (LISTOP *) expushmark->op_sibling;
9929 if (!exlist || exlist->op_type != OP_NULL
9930 || exlist->op_targ != OP_LIST)
9933 if (exlist->op_last != o) {
9934 /* Mmm. Was expecting to point back to this op. */
9937 theirmark = exlist->op_first;
9938 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9941 if (theirmark->op_sibling != o) {
9942 /* There's something between the mark and the reverse, eg
9943 for (1, reverse (...))
9948 ourmark = ((LISTOP *)o)->op_first;
9949 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9952 ourlast = ((LISTOP *)o)->op_last;
9953 if (!ourlast || ourlast->op_next != o)
9956 rv2av = ourmark->op_sibling;
9957 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9958 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9959 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9960 /* We're just reversing a single array. */
9961 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9962 enter->op_flags |= OPf_STACKED;
9965 /* We don't have control over who points to theirmark, so sacrifice
9967 theirmark->op_next = ourmark->op_next;
9968 theirmark->op_flags = ourmark->op_flags;
9969 ourlast->op_next = gvop ? gvop : (OP *) enter;
9972 enter->op_private |= OPpITER_REVERSED;
9973 iter->op_private |= OPpITER_REVERSED;
9980 UNOP *refgen, *rv2cv;
9983 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9986 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9989 rv2gv = ((BINOP *)o)->op_last;
9990 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9993 refgen = (UNOP *)((BINOP *)o)->op_first;
9995 if (!refgen || refgen->op_type != OP_REFGEN)
9998 exlist = (LISTOP *)refgen->op_first;
9999 if (!exlist || exlist->op_type != OP_NULL
10000 || exlist->op_targ != OP_LIST)
10003 if (exlist->op_first->op_type != OP_PUSHMARK)
10006 rv2cv = (UNOP*)exlist->op_last;
10008 if (rv2cv->op_type != OP_RV2CV)
10011 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10012 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10013 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10015 o->op_private |= OPpASSIGN_CV_TO_GV;
10016 rv2gv->op_private |= OPpDONT_INIT_GV;
10017 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10025 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10026 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10031 Perl_cpeep_t cpeep =
10032 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10034 cpeep(aTHX_ o, oldop);
10045 Perl_peep(pTHX_ register OP *o)
10051 =head1 Custom Operators
10053 =for apidoc Ao||custom_op_xop
10054 Return the XOP structure for a given custom op. This function should be
10055 considered internal to OP_NAME and the other access macros: use them instead.
10061 Perl_custom_op_xop(pTHX_ const OP *o)
10067 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10069 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10070 assert(o->op_type == OP_CUSTOM);
10072 /* This is wrong. It assumes a function pointer can be cast to IV,
10073 * which isn't guaranteed, but this is what the old custom OP code
10074 * did. In principle it should be safer to Copy the bytes of the
10075 * pointer into a PV: since the new interface is hidden behind
10076 * functions, this can be changed later if necessary. */
10077 /* Change custom_op_xop if this ever happens */
10078 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10081 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10083 /* assume noone will have just registered a desc */
10084 if (!he && PL_custom_op_names &&
10085 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10090 /* XXX does all this need to be shared mem? */
10091 Newxz(xop, 1, XOP);
10092 pv = SvPV(HeVAL(he), l);
10093 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10094 if (PL_custom_op_descs &&
10095 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10097 pv = SvPV(HeVAL(he), l);
10098 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10100 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10104 if (!he) return &xop_null;
10106 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10111 =for apidoc Ao||custom_op_register
10112 Register a custom op. See L<perlguts/"Custom Operators">.
10118 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10122 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10124 /* see the comment in custom_op_xop */
10125 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10127 if (!PL_custom_ops)
10128 PL_custom_ops = newHV();
10130 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10131 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10136 /* Efficient sub that returns a constant scalar value. */
10138 const_sv_xsub(pTHX_ CV* cv)
10142 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10146 /* diag_listed_as: SKIPME */
10147 Perl_croak(aTHX_ "usage: %s::%s()",
10148 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10161 * c-indentation-style: bsd
10162 * c-basic-offset: 4
10163 * indent-tabs-mode: t
10166 * ex: set ts=8 sts=4 sw=4 noet: