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;
390 if (flags & ~SVf_UTF8)
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 ((flags & SVf_UTF8) && 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_pvn(name, len,
419 (is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
421 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
422 PL_parser->in_my_stash,
424 /* $_ is always in main::, even with our */
425 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
429 /* anon sub prototypes contains state vars should always be cloned,
430 * otherwise the state var would be shared between anon subs */
432 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
433 CvCLONE_on(PL_compcv);
438 /* free the body of an op without examining its contents.
439 * Always use this rather than FreeOp directly */
442 S_op_destroy(pTHX_ OP *o)
444 if (o->op_latefree) {
452 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
454 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
460 Perl_op_free(pTHX_ OP *o)
467 if (o->op_latefreed) {
474 if (o->op_private & OPpREFCOUNTED) {
485 refcnt = OpREFCNT_dec(o);
488 /* Need to find and remove any pattern match ops from the list
489 we maintain for reset(). */
490 find_and_forget_pmops(o);
500 /* Call the op_free hook if it has been set. Do it now so that it's called
501 * at the right time for refcounted ops, but still before all of the kids
505 if (o->op_flags & OPf_KIDS) {
506 register OP *kid, *nextkid;
507 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
508 nextkid = kid->op_sibling; /* Get before next freeing kid */
513 #ifdef PERL_DEBUG_READONLY_OPS
517 /* COP* is not cleared by op_clear() so that we may track line
518 * numbers etc even after null() */
519 if (type == OP_NEXTSTATE || type == OP_DBSTATE
520 || (type == OP_NULL /* the COP might have been null'ed */
521 && ((OPCODE)o->op_targ == OP_NEXTSTATE
522 || (OPCODE)o->op_targ == OP_DBSTATE))) {
527 type = (OPCODE)o->op_targ;
530 if (o->op_latefree) {
536 #ifdef DEBUG_LEAKING_SCALARS
543 Perl_op_clear(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_OP_CLEAR;
551 mad_free(o->op_madprop);
556 switch (o->op_type) {
557 case OP_NULL: /* Was holding old type, if any. */
558 if (PL_madskills && o->op_targ != OP_NULL) {
559 o->op_type = (Optype)o->op_targ;
564 case OP_ENTEREVAL: /* Was holding hints. */
568 if (!(o->op_flags & OPf_REF)
569 || (PL_check[o->op_type] != Perl_ck_ftst))
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)
969 PL_curcop = &PL_compiling;
974 kid = cLISTOPo->op_first;
977 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
984 Perl_scalarvoid(pTHX_ OP *o)
988 const char* useless = NULL;
992 PERL_ARGS_ASSERT_SCALARVOID;
994 /* trailing mad null ops don't count as "there" for void processing */
996 o->op_type != OP_NULL &&
998 o->op_sibling->op_type == OP_NULL)
1001 for (sib = o->op_sibling;
1002 sib && sib->op_type == OP_NULL;
1003 sib = sib->op_sibling) ;
1009 if (o->op_type == OP_NEXTSTATE
1010 || o->op_type == OP_DBSTATE
1011 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1012 || o->op_targ == OP_DBSTATE)))
1013 PL_curcop = (COP*)o; /* for warning below */
1015 /* assumes no premature commitment */
1016 want = o->op_flags & OPf_WANT;
1017 if ((want && want != OPf_WANT_SCALAR)
1018 || (PL_parser && PL_parser->error_count)
1019 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1024 if ((o->op_private & OPpTARGET_MY)
1025 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1027 return scalar(o); /* As if inside SASSIGN */
1030 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1032 switch (o->op_type) {
1034 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1038 if (o->op_flags & OPf_STACKED)
1042 if (o->op_private == 4)
1067 case OP_AELEMFAST_LEX:
1086 case OP_GETSOCKNAME:
1087 case OP_GETPEERNAME:
1092 case OP_GETPRIORITY:
1116 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1117 /* Otherwise it's "Useless use of grep iterator" */
1118 useless = OP_DESC(o);
1122 kid = cLISTOPo->op_first;
1123 if (kid && kid->op_type == OP_PUSHRE
1125 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1127 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1129 useless = OP_DESC(o);
1133 kid = cUNOPo->op_first;
1134 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1135 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1138 useless = "negative pattern binding (!~)";
1142 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1143 useless = "non-destructive substitution (s///r)";
1147 useless = "non-destructive transliteration (tr///r)";
1154 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156 useless = "a variable";
1161 if (cSVOPo->op_private & OPpCONST_STRICT)
1162 no_bareword_allowed(o);
1164 if (ckWARN(WARN_VOID)) {
1166 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1167 "a constant (%"SVf")", sv));
1168 useless = SvPV_nolen(msv);
1171 useless = "a constant (undef)";
1172 if (o->op_private & OPpCONST_ARYBASE)
1174 /* don't warn on optimised away booleans, eg
1175 * use constant Foo, 5; Foo || print; */
1176 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1178 /* the constants 0 and 1 are permitted as they are
1179 conventionally used as dummies in constructs like
1180 1 while some_condition_with_side_effects; */
1181 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1183 else if (SvPOK(sv)) {
1184 /* perl4's way of mixing documentation and code
1185 (before the invention of POD) was based on a
1186 trick to mix nroff and perl code. The trick was
1187 built upon these three nroff macros being used in
1188 void context. The pink camel has the details in
1189 the script wrapman near page 319. */
1190 const char * const maybe_macro = SvPVX_const(sv);
1191 if (strnEQ(maybe_macro, "di", 2) ||
1192 strnEQ(maybe_macro, "ds", 2) ||
1193 strnEQ(maybe_macro, "ig", 2))
1198 op_null(o); /* don't execute or even remember it */
1202 o->op_type = OP_PREINC; /* pre-increment is faster */
1203 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1207 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1208 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1212 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1213 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1217 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1218 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1223 kid = cLOGOPo->op_first;
1224 if (kid->op_type == OP_NOT
1225 && (kid->op_flags & OPf_KIDS)
1227 if (o->op_type == OP_AND) {
1229 o->op_ppaddr = PL_ppaddr[OP_OR];
1231 o->op_type = OP_AND;
1232 o->op_ppaddr = PL_ppaddr[OP_AND];
1241 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (o->op_flags & OPf_STACKED)
1253 if (!(o->op_flags & OPf_KIDS))
1264 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1274 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1279 S_listkids(pTHX_ OP *o)
1281 if (o && o->op_flags & OPf_KIDS) {
1283 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1290 Perl_list(pTHX_ OP *o)
1295 /* assumes no premature commitment */
1296 if (!o || (o->op_flags & OPf_WANT)
1297 || (PL_parser && PL_parser->error_count)
1298 || o->op_type == OP_RETURN)
1303 if ((o->op_private & OPpTARGET_MY)
1304 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1306 return o; /* As if inside SASSIGN */
1309 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1311 switch (o->op_type) {
1314 list(cBINOPo->op_first);
1319 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1327 if (!(o->op_flags & OPf_KIDS))
1329 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1330 list(cBINOPo->op_first);
1331 return gen_constant_list(o);
1338 kid = cLISTOPo->op_first;
1340 kid = kid->op_sibling;
1343 OP *sib = kid->op_sibling;
1344 if (sib && kid->op_type != OP_LEAVEWHEN)
1350 PL_curcop = &PL_compiling;
1354 kid = cLISTOPo->op_first;
1361 S_scalarseq(pTHX_ OP *o)
1365 const OPCODE type = o->op_type;
1367 if (type == OP_LINESEQ || type == OP_SCOPE ||
1368 type == OP_LEAVE || type == OP_LEAVETRY)
1371 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1372 if (kid->op_sibling) {
1376 PL_curcop = &PL_compiling;
1378 o->op_flags &= ~OPf_PARENS;
1379 if (PL_hints & HINT_BLOCK_SCOPE)
1380 o->op_flags |= OPf_PARENS;
1383 o = newOP(OP_STUB, 0);
1388 S_modkids(pTHX_ OP *o, I32 type)
1390 if (o && o->op_flags & OPf_KIDS) {
1392 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1393 op_lvalue(kid, type);
1399 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1401 Propagate lvalue ("modifiable") context to an op and its children.
1402 I<type> represents the context type, roughly based on the type of op that
1403 would do the modifying, although C<local()> is represented by OP_NULL,
1404 because it has no op type of its own (it is signalled by a flag on
1407 This function detects things that can't be modified, such as C<$x+1>, and
1408 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1409 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1411 It also flags things that need to behave specially in an lvalue context,
1412 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1418 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1422 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1425 if (!o || (PL_parser && PL_parser->error_count))
1428 if ((o->op_private & OPpTARGET_MY)
1429 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1434 switch (o->op_type) {
1440 if (!(o->op_private & OPpCONST_ARYBASE))
1443 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1444 CopARYBASE_set(&PL_compiling,
1445 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1449 SAVECOPARYBASE(&PL_compiling);
1450 CopARYBASE_set(&PL_compiling, 0);
1452 else if (type == OP_REFGEN)
1455 Perl_croak(aTHX_ "That use of $[ is unsupported");
1458 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1462 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1463 !(o->op_flags & OPf_STACKED)) {
1464 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1465 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1466 poses, so we need it clear. */
1467 o->op_private &= ~1;
1468 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1469 assert(cUNOPo->op_first->op_type == OP_NULL);
1470 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1473 else if (o->op_private & OPpENTERSUB_NOMOD)
1475 else { /* lvalue subroutine call */
1476 o->op_private |= OPpLVAL_INTRO
1477 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1478 PL_modcount = RETURN_UNLIMITED_NUMBER;
1479 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1480 /* Backward compatibility mode: */
1481 o->op_private |= OPpENTERSUB_INARGS;
1484 else { /* Compile-time error message: */
1485 OP *kid = cUNOPo->op_first;
1489 if (kid->op_type != OP_PUSHMARK) {
1490 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1492 "panic: unexpected lvalue entersub "
1493 "args: type/targ %ld:%"UVuf,
1494 (long)kid->op_type, (UV)kid->op_targ);
1495 kid = kLISTOP->op_first;
1497 while (kid->op_sibling)
1498 kid = kid->op_sibling;
1499 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1501 if (kid->op_type == OP_METHOD_NAMED
1502 || kid->op_type == OP_METHOD)
1506 NewOp(1101, newop, 1, UNOP);
1507 newop->op_type = OP_RV2CV;
1508 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1509 newop->op_first = NULL;
1510 newop->op_next = (OP*)newop;
1511 kid->op_sibling = (OP*)newop;
1512 newop->op_private |= OPpLVAL_INTRO;
1513 newop->op_private &= ~1;
1517 if (kid->op_type != OP_RV2CV)
1519 "panic: unexpected lvalue entersub "
1520 "entry via type/targ %ld:%"UVuf,
1521 (long)kid->op_type, (UV)kid->op_targ);
1522 kid->op_private |= OPpLVAL_INTRO;
1523 break; /* Postpone until runtime */
1527 kid = kUNOP->op_first;
1528 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1529 kid = kUNOP->op_first;
1530 if (kid->op_type == OP_NULL)
1532 "Unexpected constant lvalue entersub "
1533 "entry via type/targ %ld:%"UVuf,
1534 (long)kid->op_type, (UV)kid->op_targ);
1535 if (kid->op_type != OP_GV) {
1536 /* Restore RV2CV to check lvalueness */
1538 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1539 okid->op_next = kid->op_next;
1540 kid->op_next = okid;
1543 okid->op_next = NULL;
1544 okid->op_type = OP_RV2CV;
1546 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1547 okid->op_private |= OPpLVAL_INTRO;
1548 okid->op_private &= ~1;
1552 cv = GvCV(kGVOP_gv);
1562 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1563 /* grep, foreach, subcalls, refgen */
1564 if (type == OP_GREPSTART || type == OP_ENTERSUB
1565 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1567 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1568 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1570 : (o->op_type == OP_ENTERSUB
1571 ? "non-lvalue subroutine call"
1573 type ? PL_op_desc[type] : "local"));
1587 case OP_RIGHT_SHIFT:
1596 if (!(o->op_flags & OPf_STACKED))
1603 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1604 op_lvalue(kid, type);
1609 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1610 PL_modcount = RETURN_UNLIMITED_NUMBER;
1611 return o; /* Treat \(@foo) like ordinary list. */
1615 if (scalar_mod_type(o, type))
1617 ref(cUNOPo->op_first, o->op_type);
1621 if (type == OP_LEAVESUBLV)
1622 o->op_private |= OPpMAYBE_LVSUB;
1628 PL_modcount = RETURN_UNLIMITED_NUMBER;
1631 PL_hints |= HINT_BLOCK_SCOPE;
1632 if (type == OP_LEAVESUBLV)
1633 o->op_private |= OPpMAYBE_LVSUB;
1637 ref(cUNOPo->op_first, o->op_type);
1641 PL_hints |= HINT_BLOCK_SCOPE;
1650 case OP_AELEMFAST_LEX:
1657 PL_modcount = RETURN_UNLIMITED_NUMBER;
1658 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1659 return o; /* Treat \(@foo) like ordinary list. */
1660 if (scalar_mod_type(o, type))
1662 if (type == OP_LEAVESUBLV)
1663 o->op_private |= OPpMAYBE_LVSUB;
1667 if (!type) /* local() */
1668 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1669 PAD_COMPNAME_SV(o->op_targ));
1678 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1682 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1688 if (type == OP_LEAVESUBLV)
1689 o->op_private |= OPpMAYBE_LVSUB;
1690 pad_free(o->op_targ);
1691 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1692 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1693 if (o->op_flags & OPf_KIDS)
1694 op_lvalue(cBINOPo->op_first->op_sibling, type);
1699 ref(cBINOPo->op_first, o->op_type);
1700 if (type == OP_ENTERSUB &&
1701 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1702 o->op_private |= OPpLVAL_DEFER;
1703 if (type == OP_LEAVESUBLV)
1704 o->op_private |= OPpMAYBE_LVSUB;
1714 if (o->op_flags & OPf_KIDS)
1715 op_lvalue(cLISTOPo->op_last, type);
1720 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1722 else if (!(o->op_flags & OPf_KIDS))
1724 if (o->op_targ != OP_LIST) {
1725 op_lvalue(cBINOPo->op_first, type);
1731 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1732 op_lvalue(kid, type);
1736 if (type != OP_LEAVESUBLV)
1738 break; /* op_lvalue()ing was handled by ck_return() */
1741 /* [20011101.069] File test operators interpret OPf_REF to mean that
1742 their argument is a filehandle; thus \stat(".") should not set
1744 if (type == OP_REFGEN &&
1745 PL_check[o->op_type] == Perl_ck_ftst)
1748 if (type != OP_LEAVESUBLV)
1749 o->op_flags |= OPf_MOD;
1751 if (type == OP_AASSIGN || type == OP_SASSIGN)
1752 o->op_flags |= OPf_SPECIAL|OPf_REF;
1753 else if (!type) { /* local() */
1756 o->op_private |= OPpLVAL_INTRO;
1757 o->op_flags &= ~OPf_SPECIAL;
1758 PL_hints |= HINT_BLOCK_SCOPE;
1763 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1764 "Useless localization of %s", OP_DESC(o));
1767 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1768 && type != OP_LEAVESUBLV)
1769 o->op_flags |= OPf_REF;
1773 /* Do not use this. It will be removed after 5.14. */
1775 Perl_mod(pTHX_ OP *o, I32 type)
1777 return op_lvalue(o,type);
1782 S_scalar_mod_type(const OP *o, I32 type)
1784 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1788 if (o->op_type == OP_RV2GV)
1812 case OP_RIGHT_SHIFT:
1833 S_is_handle_constructor(const OP *o, I32 numargs)
1835 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1837 switch (o->op_type) {
1845 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1858 S_refkids(pTHX_ OP *o, I32 type)
1860 if (o && o->op_flags & OPf_KIDS) {
1862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1869 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1874 PERL_ARGS_ASSERT_DOREF;
1876 if (!o || (PL_parser && PL_parser->error_count))
1879 switch (o->op_type) {
1881 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1882 !(o->op_flags & OPf_STACKED)) {
1883 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1884 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1885 assert(cUNOPo->op_first->op_type == OP_NULL);
1886 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1887 o->op_flags |= OPf_SPECIAL;
1888 o->op_private &= ~1;
1890 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
1891 o->op_private |= OPpENTERSUB_DEREF;
1892 o->op_flags |= OPf_MOD;
1898 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1899 doref(kid, type, set_op_ref);
1902 if (type == OP_DEFINED)
1903 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1904 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1907 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1908 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1909 : type == OP_RV2HV ? OPpDEREF_HV
1911 o->op_flags |= OPf_MOD;
1918 o->op_flags |= OPf_REF;
1921 if (type == OP_DEFINED)
1922 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1923 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1929 o->op_flags |= OPf_REF;
1934 if (!(o->op_flags & OPf_KIDS))
1936 doref(cBINOPo->op_first, type, set_op_ref);
1940 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1941 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1942 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1943 : type == OP_RV2HV ? OPpDEREF_HV
1945 o->op_flags |= OPf_MOD;
1955 if (!(o->op_flags & OPf_KIDS))
1957 doref(cLISTOPo->op_last, type, set_op_ref);
1967 S_dup_attrlist(pTHX_ OP *o)
1972 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1974 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1975 * where the first kid is OP_PUSHMARK and the remaining ones
1976 * are OP_CONST. We need to push the OP_CONST values.
1978 if (o->op_type == OP_CONST)
1979 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1981 else if (o->op_type == OP_NULL)
1985 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1987 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1988 if (o->op_type == OP_CONST)
1989 rop = op_append_elem(OP_LIST, rop,
1990 newSVOP(OP_CONST, o->op_flags,
1991 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1998 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2003 PERL_ARGS_ASSERT_APPLY_ATTRS;
2005 /* fake up C<use attributes $pkg,$rv,@attrs> */
2006 ENTER; /* need to protect against side-effects of 'use' */
2007 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2009 #define ATTRSMODULE "attributes"
2010 #define ATTRSMODULE_PM "attributes.pm"
2013 /* Don't force the C<use> if we don't need it. */
2014 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2015 if (svp && *svp != &PL_sv_undef)
2016 NOOP; /* already in %INC */
2018 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2019 newSVpvs(ATTRSMODULE), NULL);
2022 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2023 newSVpvs(ATTRSMODULE),
2025 op_prepend_elem(OP_LIST,
2026 newSVOP(OP_CONST, 0, stashsv),
2027 op_prepend_elem(OP_LIST,
2028 newSVOP(OP_CONST, 0,
2030 dup_attrlist(attrs))));
2036 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2039 OP *pack, *imop, *arg;
2042 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2047 assert(target->op_type == OP_PADSV ||
2048 target->op_type == OP_PADHV ||
2049 target->op_type == OP_PADAV);
2051 /* Ensure that attributes.pm is loaded. */
2052 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2054 /* Need package name for method call. */
2055 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2057 /* Build up the real arg-list. */
2058 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2060 arg = newOP(OP_PADSV, 0);
2061 arg->op_targ = target->op_targ;
2062 arg = op_prepend_elem(OP_LIST,
2063 newSVOP(OP_CONST, 0, stashsv),
2064 op_prepend_elem(OP_LIST,
2065 newUNOP(OP_REFGEN, 0,
2066 op_lvalue(arg, OP_REFGEN)),
2067 dup_attrlist(attrs)));
2069 /* Fake up a method call to import */
2070 meth = newSVpvs_share("import");
2071 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2072 op_append_elem(OP_LIST,
2073 op_prepend_elem(OP_LIST, pack, list(arg)),
2074 newSVOP(OP_METHOD_NAMED, 0, meth)));
2075 imop->op_private |= OPpENTERSUB_NOMOD;
2077 /* Combine the ops. */
2078 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2082 =notfor apidoc apply_attrs_string
2084 Attempts to apply a list of attributes specified by the C<attrstr> and
2085 C<len> arguments to the subroutine identified by the C<cv> argument which
2086 is expected to be associated with the package identified by the C<stashpv>
2087 argument (see L<attributes>). It gets this wrong, though, in that it
2088 does not correctly identify the boundaries of the individual attribute
2089 specifications within C<attrstr>. This is not really intended for the
2090 public API, but has to be listed here for systems such as AIX which
2091 need an explicit export list for symbols. (It's called from XS code
2092 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2093 to respect attribute syntax properly would be welcome.
2099 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2100 const char *attrstr, STRLEN len)
2104 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2107 len = strlen(attrstr);
2111 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2113 const char * const sstr = attrstr;
2114 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2115 attrs = op_append_elem(OP_LIST, attrs,
2116 newSVOP(OP_CONST, 0,
2117 newSVpvn(sstr, attrstr-sstr)));
2121 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2122 newSVpvs(ATTRSMODULE),
2123 NULL, op_prepend_elem(OP_LIST,
2124 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2125 op_prepend_elem(OP_LIST,
2126 newSVOP(OP_CONST, 0,
2127 newRV(MUTABLE_SV(cv))),
2132 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2136 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2138 PERL_ARGS_ASSERT_MY_KID;
2140 if (!o || (PL_parser && PL_parser->error_count))
2144 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2145 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2149 if (type == OP_LIST) {
2151 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2152 my_kid(kid, attrs, imopsp);
2153 } else if (type == OP_UNDEF
2159 } else if (type == OP_RV2SV || /* "our" declaration */
2161 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2162 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2163 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2165 PL_parser->in_my == KEY_our
2167 : PL_parser->in_my == KEY_state ? "state" : "my"));
2169 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2170 PL_parser->in_my = FALSE;
2171 PL_parser->in_my_stash = NULL;
2172 apply_attrs(GvSTASH(gv),
2173 (type == OP_RV2SV ? GvSV(gv) :
2174 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2175 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2178 o->op_private |= OPpOUR_INTRO;
2181 else if (type != OP_PADSV &&
2184 type != OP_PUSHMARK)
2186 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2188 PL_parser->in_my == KEY_our
2190 : PL_parser->in_my == KEY_state ? "state" : "my"));
2193 else if (attrs && type != OP_PUSHMARK) {
2196 PL_parser->in_my = FALSE;
2197 PL_parser->in_my_stash = NULL;
2199 /* check for C<my Dog $spot> when deciding package */
2200 stash = PAD_COMPNAME_TYPE(o->op_targ);
2202 stash = PL_curstash;
2203 apply_attrs_my(stash, o, attrs, imopsp);
2205 o->op_flags |= OPf_MOD;
2206 o->op_private |= OPpLVAL_INTRO;
2208 o->op_private |= OPpPAD_STATE;
2213 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2217 int maybe_scalar = 0;
2219 PERL_ARGS_ASSERT_MY_ATTRS;
2221 /* [perl #17376]: this appears to be premature, and results in code such as
2222 C< our(%x); > executing in list mode rather than void mode */
2224 if (o->op_flags & OPf_PARENS)
2234 o = my_kid(o, attrs, &rops);
2236 if (maybe_scalar && o->op_type == OP_PADSV) {
2237 o = scalar(op_append_list(OP_LIST, rops, o));
2238 o->op_private |= OPpLVAL_INTRO;
2241 /* The listop in rops might have a pushmark at the beginning,
2242 which will mess up list assignment. */
2243 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2244 if (rops->op_type == OP_LIST &&
2245 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2247 OP * const pushmark = lrops->op_first;
2248 lrops->op_first = pushmark->op_sibling;
2251 o = op_append_list(OP_LIST, o, rops);
2254 PL_parser->in_my = FALSE;
2255 PL_parser->in_my_stash = NULL;
2260 Perl_sawparens(pTHX_ OP *o)
2262 PERL_UNUSED_CONTEXT;
2264 o->op_flags |= OPf_PARENS;
2269 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2273 const OPCODE ltype = left->op_type;
2274 const OPCODE rtype = right->op_type;
2276 PERL_ARGS_ASSERT_BIND_MATCH;
2278 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2279 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2281 const char * const desc
2283 rtype == OP_SUBST || rtype == OP_TRANS
2284 || rtype == OP_TRANSR
2286 ? (int)rtype : OP_MATCH];
2287 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2288 ? "@array" : "%hash");
2289 Perl_warner(aTHX_ packWARN(WARN_MISC),
2290 "Applying %s to %s will act on scalar(%s)",
2291 desc, sample, sample);
2294 if (rtype == OP_CONST &&
2295 cSVOPx(right)->op_private & OPpCONST_BARE &&
2296 cSVOPx(right)->op_private & OPpCONST_STRICT)
2298 no_bareword_allowed(right);
2301 /* !~ doesn't make sense with /r, so error on it for now */
2302 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2304 yyerror("Using !~ with s///r doesn't make sense");
2305 if (rtype == OP_TRANSR && type == OP_NOT)
2306 yyerror("Using !~ with tr///r doesn't make sense");
2308 ismatchop = (rtype == OP_MATCH ||
2309 rtype == OP_SUBST ||
2310 rtype == OP_TRANS || rtype == OP_TRANSR)
2311 && !(right->op_flags & OPf_SPECIAL);
2312 if (ismatchop && right->op_private & OPpTARGET_MY) {
2314 right->op_private &= ~OPpTARGET_MY;
2316 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2319 right->op_flags |= OPf_STACKED;
2320 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2321 ! (rtype == OP_TRANS &&
2322 right->op_private & OPpTRANS_IDENTICAL) &&
2323 ! (rtype == OP_SUBST &&
2324 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2325 newleft = op_lvalue(left, rtype);
2328 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2329 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2331 o = op_prepend_elem(rtype, scalar(newleft), right);
2333 return newUNOP(OP_NOT, 0, scalar(o));
2337 return bind_match(type, left,
2338 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2342 Perl_invert(pTHX_ OP *o)
2346 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2350 =for apidoc Amx|OP *|op_scope|OP *o
2352 Wraps up an op tree with some additional ops so that at runtime a dynamic
2353 scope will be created. The original ops run in the new dynamic scope,
2354 and then, provided that they exit normally, the scope will be unwound.
2355 The additional ops used to create and unwind the dynamic scope will
2356 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2357 instead if the ops are simple enough to not need the full dynamic scope
2364 Perl_op_scope(pTHX_ OP *o)
2368 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2369 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2370 o->op_type = OP_LEAVE;
2371 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2373 else if (o->op_type == OP_LINESEQ) {
2375 o->op_type = OP_SCOPE;
2376 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2377 kid = ((LISTOP*)o)->op_first;
2378 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2381 /* The following deals with things like 'do {1 for 1}' */
2382 kid = kid->op_sibling;
2384 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2389 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2395 Perl_block_start(pTHX_ int full)
2398 const int retval = PL_savestack_ix;
2400 pad_block_start(full);
2402 PL_hints &= ~HINT_BLOCK_SCOPE;
2403 SAVECOMPILEWARNINGS();
2404 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2406 CALL_BLOCK_HOOKS(bhk_start, full);
2412 Perl_block_end(pTHX_ I32 floor, OP *seq)
2415 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2416 OP* retval = scalarseq(seq);
2418 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2421 CopHINTS_set(&PL_compiling, PL_hints);
2423 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2426 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2432 =head1 Compile-time scope hooks
2434 =for apidoc Aox||blockhook_register
2436 Register a set of hooks to be called when the Perl lexical scope changes
2437 at compile time. See L<perlguts/"Compile-time scope hooks">.
2443 Perl_blockhook_register(pTHX_ BHK *hk)
2445 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2447 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2454 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2455 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2456 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2459 OP * const o = newOP(OP_PADSV, 0);
2460 o->op_targ = offset;
2466 Perl_newPROG(pTHX_ OP *o)
2470 PERL_ARGS_ASSERT_NEWPROG;
2475 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2476 ((PL_in_eval & EVAL_KEEPERR)
2477 ? OPf_SPECIAL : 0), o);
2478 /* don't use LINKLIST, since PL_eval_root might indirect through
2479 * a rather expensive function call and LINKLIST evaluates its
2480 * argument more than once */
2481 PL_eval_start = op_linklist(PL_eval_root);
2482 PL_eval_root->op_private |= OPpREFCOUNTED;
2483 OpREFCNT_set(PL_eval_root, 1);
2484 PL_eval_root->op_next = 0;
2485 CALL_PEEP(PL_eval_start);
2488 if (o->op_type == OP_STUB) {
2489 PL_comppad_name = 0;
2491 S_op_destroy(aTHX_ o);
2494 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2495 PL_curcop = &PL_compiling;
2496 PL_main_start = LINKLIST(PL_main_root);
2497 PL_main_root->op_private |= OPpREFCOUNTED;
2498 OpREFCNT_set(PL_main_root, 1);
2499 PL_main_root->op_next = 0;
2500 CALL_PEEP(PL_main_start);
2503 /* Register with debugger */
2505 CV * const cv = get_cvs("DB::postponed", 0);
2509 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2511 call_sv(MUTABLE_SV(cv), G_DISCARD);
2518 Perl_localize(pTHX_ OP *o, I32 lex)
2522 PERL_ARGS_ASSERT_LOCALIZE;
2524 if (o->op_flags & OPf_PARENS)
2525 /* [perl #17376]: this appears to be premature, and results in code such as
2526 C< our(%x); > executing in list mode rather than void mode */
2533 if ( PL_parser->bufptr > PL_parser->oldbufptr
2534 && PL_parser->bufptr[-1] == ','
2535 && ckWARN(WARN_PARENTHESIS))
2537 char *s = PL_parser->bufptr;
2540 /* some heuristics to detect a potential error */
2541 while (*s && (strchr(", \t\n", *s)))
2545 if (*s && strchr("@$%*", *s) && *++s
2546 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2549 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2551 while (*s && (strchr(", \t\n", *s)))
2557 if (sigil && (*s == ';' || *s == '=')) {
2558 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2559 "Parentheses missing around \"%s\" list",
2561 ? (PL_parser->in_my == KEY_our
2563 : PL_parser->in_my == KEY_state
2573 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2574 PL_parser->in_my = FALSE;
2575 PL_parser->in_my_stash = NULL;
2580 Perl_jmaybe(pTHX_ OP *o)
2582 PERL_ARGS_ASSERT_JMAYBE;
2584 if (o->op_type == OP_LIST) {
2586 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2587 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2593 S_fold_constants(pTHX_ register OP *o)
2596 register OP * VOL curop;
2598 VOL I32 type = o->op_type;
2603 SV * const oldwarnhook = PL_warnhook;
2604 SV * const olddiehook = PL_diehook;
2608 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2610 if (PL_opargs[type] & OA_RETSCALAR)
2612 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2613 o->op_targ = pad_alloc(type, SVs_PADTMP);
2615 /* integerize op, unless it happens to be C<-foo>.
2616 * XXX should pp_i_negate() do magic string negation instead? */
2617 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2618 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2619 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2621 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2624 if (!(PL_opargs[type] & OA_FOLDCONST))
2629 /* XXX might want a ck_negate() for this */
2630 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2642 /* XXX what about the numeric ops? */
2643 if (PL_hints & HINT_LOCALE)
2648 if (PL_parser && PL_parser->error_count)
2649 goto nope; /* Don't try to run w/ errors */
2651 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2652 const OPCODE type = curop->op_type;
2653 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2655 type != OP_SCALAR &&
2657 type != OP_PUSHMARK)
2663 curop = LINKLIST(o);
2664 old_next = o->op_next;
2668 oldscope = PL_scopestack_ix;
2669 create_eval_scope(G_FAKINGEVAL);
2671 /* Verify that we don't need to save it: */
2672 assert(PL_curcop == &PL_compiling);
2673 StructCopy(&PL_compiling, ¬_compiling, COP);
2674 PL_curcop = ¬_compiling;
2675 /* The above ensures that we run with all the correct hints of the
2676 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2677 assert(IN_PERL_RUNTIME);
2678 PL_warnhook = PERL_WARNHOOK_FATAL;
2685 sv = *(PL_stack_sp--);
2686 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2688 /* Can't simply swipe the SV from the pad, because that relies on
2689 the op being freed "real soon now". Under MAD, this doesn't
2690 happen (see the #ifdef below). */
2693 pad_swipe(o->op_targ, FALSE);
2696 else if (SvTEMP(sv)) { /* grab mortal temp? */
2697 SvREFCNT_inc_simple_void(sv);
2702 /* Something tried to die. Abandon constant folding. */
2703 /* Pretend the error never happened. */
2705 o->op_next = old_next;
2709 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2710 PL_warnhook = oldwarnhook;
2711 PL_diehook = olddiehook;
2712 /* XXX note that this croak may fail as we've already blown away
2713 * the stack - eg any nested evals */
2714 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2717 PL_warnhook = oldwarnhook;
2718 PL_diehook = olddiehook;
2719 PL_curcop = &PL_compiling;
2721 if (PL_scopestack_ix > oldscope)
2722 delete_eval_scope();
2731 if (type == OP_RV2GV)
2732 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2734 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2735 op_getmad(o,newop,'f');
2743 S_gen_constant_list(pTHX_ register OP *o)
2747 const I32 oldtmps_floor = PL_tmps_floor;
2750 if (PL_parser && PL_parser->error_count)
2751 return o; /* Don't attempt to run with errors */
2753 PL_op = curop = LINKLIST(o);
2756 Perl_pp_pushmark(aTHX);
2759 assert (!(curop->op_flags & OPf_SPECIAL));
2760 assert(curop->op_type == OP_RANGE);
2761 Perl_pp_anonlist(aTHX);
2762 PL_tmps_floor = oldtmps_floor;
2764 o->op_type = OP_RV2AV;
2765 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2766 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2767 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2768 o->op_opt = 0; /* needs to be revisited in rpeep() */
2769 curop = ((UNOP*)o)->op_first;
2770 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2772 op_getmad(curop,o,'O');
2781 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2784 if (!o || o->op_type != OP_LIST)
2785 o = newLISTOP(OP_LIST, 0, o, NULL);
2787 o->op_flags &= ~OPf_WANT;
2789 if (!(PL_opargs[type] & OA_MARK))
2790 op_null(cLISTOPo->op_first);
2792 o->op_type = (OPCODE)type;
2793 o->op_ppaddr = PL_ppaddr[type];
2794 o->op_flags |= flags;
2796 o = CHECKOP(type, o);
2797 if (o->op_type != (unsigned)type)
2800 return fold_constants(o);
2804 =head1 Optree Manipulation Functions
2807 /* List constructors */
2810 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2812 Append an item to the list of ops contained directly within a list-type
2813 op, returning the lengthened list. I<first> is the list-type op,
2814 and I<last> is the op to append to the list. I<optype> specifies the
2815 intended opcode for the list. If I<first> is not already a list of the
2816 right type, it will be upgraded into one. If either I<first> or I<last>
2817 is null, the other is returned unchanged.
2823 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2831 if (first->op_type != (unsigned)type
2832 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2834 return newLISTOP(type, 0, first, last);
2837 if (first->op_flags & OPf_KIDS)
2838 ((LISTOP*)first)->op_last->op_sibling = last;
2840 first->op_flags |= OPf_KIDS;
2841 ((LISTOP*)first)->op_first = last;
2843 ((LISTOP*)first)->op_last = last;
2848 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2850 Concatenate the lists of ops contained directly within two list-type ops,
2851 returning the combined list. I<first> and I<last> are the list-type ops
2852 to concatenate. I<optype> specifies the intended opcode for the list.
2853 If either I<first> or I<last> is not already a list of the right type,
2854 it will be upgraded into one. If either I<first> or I<last> is null,
2855 the other is returned unchanged.
2861 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2869 if (first->op_type != (unsigned)type)
2870 return op_prepend_elem(type, first, last);
2872 if (last->op_type != (unsigned)type)
2873 return op_append_elem(type, first, last);
2875 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2876 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2877 first->op_flags |= (last->op_flags & OPf_KIDS);
2880 if (((LISTOP*)last)->op_first && first->op_madprop) {
2881 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2883 while (mp->mad_next)
2885 mp->mad_next = first->op_madprop;
2888 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2891 first->op_madprop = last->op_madprop;
2892 last->op_madprop = 0;
2895 S_op_destroy(aTHX_ last);
2901 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2903 Prepend an item to the list of ops contained directly within a list-type
2904 op, returning the lengthened list. I<first> is the op to prepend to the
2905 list, and I<last> is the list-type op. I<optype> specifies the intended
2906 opcode for the list. If I<last> is not already a list of the right type,
2907 it will be upgraded into one. If either I<first> or I<last> is null,
2908 the other is returned unchanged.
2914 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2922 if (last->op_type == (unsigned)type) {
2923 if (type == OP_LIST) { /* already a PUSHMARK there */
2924 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2925 ((LISTOP*)last)->op_first->op_sibling = first;
2926 if (!(first->op_flags & OPf_PARENS))
2927 last->op_flags &= ~OPf_PARENS;
2930 if (!(last->op_flags & OPf_KIDS)) {
2931 ((LISTOP*)last)->op_last = first;
2932 last->op_flags |= OPf_KIDS;
2934 first->op_sibling = ((LISTOP*)last)->op_first;
2935 ((LISTOP*)last)->op_first = first;
2937 last->op_flags |= OPf_KIDS;
2941 return newLISTOP(type, 0, first, last);
2949 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2952 Newxz(tk, 1, TOKEN);
2953 tk->tk_type = (OPCODE)optype;
2954 tk->tk_type = 12345;
2956 tk->tk_mad = madprop;
2961 Perl_token_free(pTHX_ TOKEN* tk)
2963 PERL_ARGS_ASSERT_TOKEN_FREE;
2965 if (tk->tk_type != 12345)
2967 mad_free(tk->tk_mad);
2972 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2977 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2979 if (tk->tk_type != 12345) {
2980 Perl_warner(aTHX_ packWARN(WARN_MISC),
2981 "Invalid TOKEN object ignored");
2988 /* faked up qw list? */
2990 tm->mad_type == MAD_SV &&
2991 SvPVX((SV *)tm->mad_val)[0] == 'q')
2998 /* pretend constant fold didn't happen? */
2999 if (mp->mad_key == 'f' &&
3000 (o->op_type == OP_CONST ||
3001 o->op_type == OP_GV) )
3003 token_getmad(tk,(OP*)mp->mad_val,slot);
3017 if (mp->mad_key == 'X')
3018 mp->mad_key = slot; /* just change the first one */
3028 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3037 /* pretend constant fold didn't happen? */
3038 if (mp->mad_key == 'f' &&
3039 (o->op_type == OP_CONST ||
3040 o->op_type == OP_GV) )
3042 op_getmad(from,(OP*)mp->mad_val,slot);
3049 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3052 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3058 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3067 /* pretend constant fold didn't happen? */
3068 if (mp->mad_key == 'f' &&
3069 (o->op_type == OP_CONST ||
3070 o->op_type == OP_GV) )
3072 op_getmad(from,(OP*)mp->mad_val,slot);
3079 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3082 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3086 PerlIO_printf(PerlIO_stderr(),
3087 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3093 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3111 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3115 addmad(tm, &(o->op_madprop), slot);
3119 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3140 Perl_newMADsv(pTHX_ char key, SV* sv)
3142 PERL_ARGS_ASSERT_NEWMADSV;
3144 return newMADPROP(key, MAD_SV, sv, 0);
3148 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3150 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3153 mp->mad_vlen = vlen;
3154 mp->mad_type = type;
3156 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3161 Perl_mad_free(pTHX_ MADPROP* mp)
3163 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3167 mad_free(mp->mad_next);
3168 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3169 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3170 switch (mp->mad_type) {
3174 Safefree((char*)mp->mad_val);
3177 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3178 op_free((OP*)mp->mad_val);
3181 sv_free(MUTABLE_SV(mp->mad_val));
3184 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3187 PerlMemShared_free(mp);
3193 =head1 Optree construction
3195 =for apidoc Am|OP *|newNULLLIST
3197 Constructs, checks, and returns a new C<stub> op, which represents an
3198 empty list expression.
3204 Perl_newNULLLIST(pTHX)
3206 return newOP(OP_STUB, 0);
3210 S_force_list(pTHX_ OP *o)
3212 if (!o || o->op_type != OP_LIST)
3213 o = newLISTOP(OP_LIST, 0, o, NULL);
3219 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3221 Constructs, checks, and returns an op of any list type. I<type> is
3222 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3223 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3224 supply up to two ops to be direct children of the list op; they are
3225 consumed by this function and become part of the constructed op tree.
3231 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3236 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3238 NewOp(1101, listop, 1, LISTOP);
3240 listop->op_type = (OPCODE)type;
3241 listop->op_ppaddr = PL_ppaddr[type];
3244 listop->op_flags = (U8)flags;
3248 else if (!first && last)
3251 first->op_sibling = last;
3252 listop->op_first = first;
3253 listop->op_last = last;
3254 if (type == OP_LIST) {
3255 OP* const pushop = newOP(OP_PUSHMARK, 0);
3256 pushop->op_sibling = first;
3257 listop->op_first = pushop;
3258 listop->op_flags |= OPf_KIDS;
3260 listop->op_last = pushop;
3263 return CHECKOP(type, listop);
3267 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3269 Constructs, checks, and returns an op of any base type (any type that
3270 has no extra fields). I<type> is the opcode. I<flags> gives the
3271 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3278 Perl_newOP(pTHX_ I32 type, I32 flags)
3283 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3284 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3285 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3286 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3288 NewOp(1101, o, 1, OP);
3289 o->op_type = (OPCODE)type;
3290 o->op_ppaddr = PL_ppaddr[type];
3291 o->op_flags = (U8)flags;
3293 o->op_latefreed = 0;
3297 o->op_private = (U8)(0 | (flags >> 8));
3298 if (PL_opargs[type] & OA_RETSCALAR)
3300 if (PL_opargs[type] & OA_TARGET)
3301 o->op_targ = pad_alloc(type, SVs_PADTMP);
3302 return CHECKOP(type, o);
3306 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3308 Constructs, checks, and returns an op of any unary type. I<type> is
3309 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3310 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3311 bits, the eight bits of C<op_private>, except that the bit with value 1
3312 is automatically set. I<first> supplies an optional op to be the direct
3313 child of the unary op; it is consumed by this function and become part
3314 of the constructed op tree.
3320 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3325 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3326 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3327 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3328 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3329 || type == OP_SASSIGN
3330 || type == OP_ENTERTRY
3331 || type == OP_NULL );
3334 first = newOP(OP_STUB, 0);
3335 if (PL_opargs[type] & OA_MARK)
3336 first = force_list(first);
3338 NewOp(1101, unop, 1, UNOP);
3339 unop->op_type = (OPCODE)type;
3340 unop->op_ppaddr = PL_ppaddr[type];
3341 unop->op_first = first;
3342 unop->op_flags = (U8)(flags | OPf_KIDS);
3343 unop->op_private = (U8)(1 | (flags >> 8));
3344 unop = (UNOP*) CHECKOP(type, unop);
3348 return fold_constants((OP *) unop);
3352 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3354 Constructs, checks, and returns an op of any binary type. I<type>
3355 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3356 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3357 the eight bits of C<op_private>, except that the bit with value 1 or
3358 2 is automatically set as required. I<first> and I<last> supply up to
3359 two ops to be the direct children of the binary op; they are consumed
3360 by this function and become part of the constructed op tree.
3366 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3371 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3372 || type == OP_SASSIGN || type == OP_NULL );
3374 NewOp(1101, binop, 1, BINOP);
3377 first = newOP(OP_NULL, 0);
3379 binop->op_type = (OPCODE)type;
3380 binop->op_ppaddr = PL_ppaddr[type];
3381 binop->op_first = first;
3382 binop->op_flags = (U8)(flags | OPf_KIDS);
3385 binop->op_private = (U8)(1 | (flags >> 8));
3388 binop->op_private = (U8)(2 | (flags >> 8));
3389 first->op_sibling = last;
3392 binop = (BINOP*)CHECKOP(type, binop);
3393 if (binop->op_next || binop->op_type != (OPCODE)type)
3396 binop->op_last = binop->op_first->op_sibling;
3398 return fold_constants((OP *)binop);
3401 static int uvcompare(const void *a, const void *b)
3402 __attribute__nonnull__(1)
3403 __attribute__nonnull__(2)
3404 __attribute__pure__;
3405 static int uvcompare(const void *a, const void *b)
3407 if (*((const UV *)a) < (*(const UV *)b))
3409 if (*((const UV *)a) > (*(const UV *)b))
3411 if (*((const UV *)a+1) < (*(const UV *)b+1))
3413 if (*((const UV *)a+1) > (*(const UV *)b+1))
3419 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3422 SV * const tstr = ((SVOP*)expr)->op_sv;
3425 (repl->op_type == OP_NULL)
3426 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3428 ((SVOP*)repl)->op_sv;
3431 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3432 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3436 register short *tbl;
3438 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3439 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3440 I32 del = o->op_private & OPpTRANS_DELETE;
3443 PERL_ARGS_ASSERT_PMTRANS;
3445 PL_hints |= HINT_BLOCK_SCOPE;
3448 o->op_private |= OPpTRANS_FROM_UTF;
3451 o->op_private |= OPpTRANS_TO_UTF;
3453 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3454 SV* const listsv = newSVpvs("# comment\n");
3456 const U8* tend = t + tlen;
3457 const U8* rend = r + rlen;
3471 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3472 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3475 const U32 flags = UTF8_ALLOW_DEFAULT;
3479 t = tsave = bytes_to_utf8(t, &len);
3482 if (!to_utf && rlen) {
3484 r = rsave = bytes_to_utf8(r, &len);
3488 /* There are several snags with this code on EBCDIC:
3489 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3490 2. scan_const() in toke.c has encoded chars in native encoding which makes
3491 ranges at least in EBCDIC 0..255 range the bottom odd.
3495 U8 tmpbuf[UTF8_MAXBYTES+1];
3498 Newx(cp, 2*tlen, UV);
3500 transv = newSVpvs("");
3502 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3504 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3506 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3510 cp[2*i+1] = cp[2*i];
3514 qsort(cp, i, 2*sizeof(UV), uvcompare);
3515 for (j = 0; j < i; j++) {
3517 diff = val - nextmin;
3519 t = uvuni_to_utf8(tmpbuf,nextmin);
3520 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3522 U8 range_mark = UTF_TO_NATIVE(0xff);
3523 t = uvuni_to_utf8(tmpbuf, val - 1);
3524 sv_catpvn(transv, (char *)&range_mark, 1);
3525 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3532 t = uvuni_to_utf8(tmpbuf,nextmin);
3533 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3535 U8 range_mark = UTF_TO_NATIVE(0xff);
3536 sv_catpvn(transv, (char *)&range_mark, 1);
3538 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3539 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3540 t = (const U8*)SvPVX_const(transv);
3541 tlen = SvCUR(transv);
3545 else if (!rlen && !del) {
3546 r = t; rlen = tlen; rend = tend;
3549 if ((!rlen && !del) || t == r ||
3550 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3552 o->op_private |= OPpTRANS_IDENTICAL;
3556 while (t < tend || tfirst <= tlast) {
3557 /* see if we need more "t" chars */
3558 if (tfirst > tlast) {
3559 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3561 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3563 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3570 /* now see if we need more "r" chars */
3571 if (rfirst > rlast) {
3573 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3575 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3577 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3586 rfirst = rlast = 0xffffffff;
3590 /* now see which range will peter our first, if either. */
3591 tdiff = tlast - tfirst;
3592 rdiff = rlast - rfirst;
3599 if (rfirst == 0xffffffff) {
3600 diff = tdiff; /* oops, pretend rdiff is infinite */
3602 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3603 (long)tfirst, (long)tlast);
3605 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3609 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3610 (long)tfirst, (long)(tfirst + diff),
3613 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3614 (long)tfirst, (long)rfirst);
3616 if (rfirst + diff > max)
3617 max = rfirst + diff;
3619 grows = (tfirst < rfirst &&
3620 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3632 else if (max > 0xff)
3637 PerlMemShared_free(cPVOPo->op_pv);
3638 cPVOPo->op_pv = NULL;
3640 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3642 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3643 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3644 PAD_SETSV(cPADOPo->op_padix, swash);
3646 SvREADONLY_on(swash);
3648 cSVOPo->op_sv = swash;
3650 SvREFCNT_dec(listsv);
3651 SvREFCNT_dec(transv);
3653 if (!del && havefinal && rlen)
3654 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3655 newSVuv((UV)final), 0);
3658 o->op_private |= OPpTRANS_GROWS;
3664 op_getmad(expr,o,'e');
3665 op_getmad(repl,o,'r');
3673 tbl = (short*)cPVOPo->op_pv;
3675 Zero(tbl, 256, short);
3676 for (i = 0; i < (I32)tlen; i++)
3678 for (i = 0, j = 0; i < 256; i++) {
3680 if (j >= (I32)rlen) {
3689 if (i < 128 && r[j] >= 128)
3699 o->op_private |= OPpTRANS_IDENTICAL;
3701 else if (j >= (I32)rlen)
3706 PerlMemShared_realloc(tbl,
3707 (0x101+rlen-j) * sizeof(short));
3708 cPVOPo->op_pv = (char*)tbl;
3710 tbl[0x100] = (short)(rlen - j);
3711 for (i=0; i < (I32)rlen - j; i++)
3712 tbl[0x101+i] = r[j+i];
3716 if (!rlen && !del) {
3719 o->op_private |= OPpTRANS_IDENTICAL;
3721 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3722 o->op_private |= OPpTRANS_IDENTICAL;
3724 for (i = 0; i < 256; i++)
3726 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3727 if (j >= (I32)rlen) {
3729 if (tbl[t[i]] == -1)
3735 if (tbl[t[i]] == -1) {
3736 if (t[i] < 128 && r[j] >= 128)
3743 if(del && rlen == tlen) {
3744 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3745 } else if(rlen > tlen) {
3746 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3750 o->op_private |= OPpTRANS_GROWS;
3752 op_getmad(expr,o,'e');
3753 op_getmad(repl,o,'r');
3763 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3765 Constructs, checks, and returns an op of any pattern matching type.
3766 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3767 and, shifted up eight bits, the eight bits of C<op_private>.
3773 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3778 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3780 NewOp(1101, pmop, 1, PMOP);
3781 pmop->op_type = (OPCODE)type;
3782 pmop->op_ppaddr = PL_ppaddr[type];
3783 pmop->op_flags = (U8)flags;
3784 pmop->op_private = (U8)(0 | (flags >> 8));
3786 if (PL_hints & HINT_RE_TAINT)
3787 pmop->op_pmflags |= PMf_RETAINT;
3788 if (PL_hints & HINT_LOCALE) {
3789 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
3791 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3792 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
3794 if (PL_hints & HINT_RE_FLAGS) {
3795 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3796 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3798 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3799 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3800 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
3802 if (reflags && SvOK(reflags)) {
3803 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
3809 assert(SvPOK(PL_regex_pad[0]));
3810 if (SvCUR(PL_regex_pad[0])) {
3811 /* Pop off the "packed" IV from the end. */
3812 SV *const repointer_list = PL_regex_pad[0];
3813 const char *p = SvEND(repointer_list) - sizeof(IV);
3814 const IV offset = *((IV*)p);
3816 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3818 SvEND_set(repointer_list, p);
3820 pmop->op_pmoffset = offset;
3821 /* This slot should be free, so assert this: */
3822 assert(PL_regex_pad[offset] == &PL_sv_undef);
3824 SV * const repointer = &PL_sv_undef;
3825 av_push(PL_regex_padav, repointer);
3826 pmop->op_pmoffset = av_len(PL_regex_padav);
3827 PL_regex_pad = AvARRAY(PL_regex_padav);
3831 return CHECKOP(type, pmop);
3834 /* Given some sort of match op o, and an expression expr containing a
3835 * pattern, either compile expr into a regex and attach it to o (if it's
3836 * constant), or convert expr into a runtime regcomp op sequence (if it's
3839 * isreg indicates that the pattern is part of a regex construct, eg
3840 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3841 * split "pattern", which aren't. In the former case, expr will be a list
3842 * if the pattern contains more than one term (eg /a$b/) or if it contains
3843 * a replacement, ie s/// or tr///.
3847 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3852 I32 repl_has_vars = 0;
3856 PERL_ARGS_ASSERT_PMRUNTIME;
3859 o->op_type == OP_SUBST
3860 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3862 /* last element in list is the replacement; pop it */
3864 repl = cLISTOPx(expr)->op_last;
3865 kid = cLISTOPx(expr)->op_first;
3866 while (kid->op_sibling != repl)
3867 kid = kid->op_sibling;
3868 kid->op_sibling = NULL;
3869 cLISTOPx(expr)->op_last = kid;
3872 if (isreg && expr->op_type == OP_LIST &&
3873 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3875 /* convert single element list to element */
3876 OP* const oe = expr;
3877 expr = cLISTOPx(oe)->op_first->op_sibling;
3878 cLISTOPx(oe)->op_first->op_sibling = NULL;
3879 cLISTOPx(oe)->op_last = NULL;
3883 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3884 return pmtrans(o, expr, repl);
3887 reglist = isreg && expr->op_type == OP_LIST;
3891 PL_hints |= HINT_BLOCK_SCOPE;
3894 if (expr->op_type == OP_CONST) {
3895 SV *pat = ((SVOP*)expr)->op_sv;
3896 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
3898 if (o->op_flags & OPf_SPECIAL)
3899 pm_flags |= RXf_SPLIT;
3902 assert (SvUTF8(pat));
3903 } else if (SvUTF8(pat)) {
3904 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3905 trapped in use 'bytes'? */
3906 /* Make a copy of the octet sequence, but without the flag on, as
3907 the compiler now honours the SvUTF8 flag on pat. */
3909 const char *const p = SvPV(pat, len);
3910 pat = newSVpvn_flags(p, len, SVs_TEMP);
3913 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3916 op_getmad(expr,(OP*)pm,'e');
3922 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3923 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3925 : OP_REGCMAYBE),0,expr);
3927 NewOp(1101, rcop, 1, LOGOP);
3928 rcop->op_type = OP_REGCOMP;
3929 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3930 rcop->op_first = scalar(expr);
3931 rcop->op_flags |= OPf_KIDS
3932 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3933 | (reglist ? OPf_STACKED : 0);
3934 rcop->op_private = 1;
3937 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3939 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3940 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
3942 /* establish postfix order */
3943 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3945 rcop->op_next = expr;
3946 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3949 rcop->op_next = LINKLIST(expr);
3950 expr->op_next = (OP*)rcop;
3953 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3958 if (pm->op_pmflags & PMf_EVAL) {
3960 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3961 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3963 else if (repl->op_type == OP_CONST)
3967 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3968 if (curop->op_type == OP_SCOPE
3969 || curop->op_type == OP_LEAVE
3970 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3971 if (curop->op_type == OP_GV) {
3972 GV * const gv = cGVOPx_gv(curop);
3974 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3977 else if (curop->op_type == OP_RV2CV)
3979 else if (curop->op_type == OP_RV2SV ||
3980 curop->op_type == OP_RV2AV ||
3981 curop->op_type == OP_RV2HV ||
3982 curop->op_type == OP_RV2GV) {
3983 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3986 else if (curop->op_type == OP_PADSV ||
3987 curop->op_type == OP_PADAV ||
3988 curop->op_type == OP_PADHV ||
3989 curop->op_type == OP_PADANY)
3993 else if (curop->op_type == OP_PUSHRE)
3994 NOOP; /* Okay here, dangerous in newASSIGNOP */
4004 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4006 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4007 op_prepend_elem(o->op_type, scalar(repl), o);
4010 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4011 pm->op_pmflags |= PMf_MAYBE_CONST;
4013 NewOp(1101, rcop, 1, LOGOP);
4014 rcop->op_type = OP_SUBSTCONT;
4015 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4016 rcop->op_first = scalar(repl);
4017 rcop->op_flags |= OPf_KIDS;
4018 rcop->op_private = 1;
4021 /* establish postfix order */
4022 rcop->op_next = LINKLIST(repl);
4023 repl->op_next = (OP*)rcop;
4025 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4026 assert(!(pm->op_pmflags & PMf_ONCE));
4027 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4036 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4038 Constructs, checks, and returns an op of any type that involves an
4039 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4040 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4041 takes ownership of one reference to it.
4047 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4052 PERL_ARGS_ASSERT_NEWSVOP;
4054 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4055 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4056 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4058 NewOp(1101, svop, 1, SVOP);
4059 svop->op_type = (OPCODE)type;
4060 svop->op_ppaddr = PL_ppaddr[type];
4062 svop->op_next = (OP*)svop;
4063 svop->op_flags = (U8)flags;
4064 if (PL_opargs[type] & OA_RETSCALAR)
4066 if (PL_opargs[type] & OA_TARGET)
4067 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4068 return CHECKOP(type, svop);
4074 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4076 Constructs, checks, and returns an op of any type that involves a
4077 reference to a pad element. I<type> is the opcode. I<flags> gives the
4078 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4079 is populated with I<sv>; this function takes ownership of one reference
4082 This function only exists if Perl has been compiled to use ithreads.
4088 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4093 PERL_ARGS_ASSERT_NEWPADOP;
4095 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4096 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4097 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4099 NewOp(1101, padop, 1, PADOP);
4100 padop->op_type = (OPCODE)type;
4101 padop->op_ppaddr = PL_ppaddr[type];
4102 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4103 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4104 PAD_SETSV(padop->op_padix, sv);
4107 padop->op_next = (OP*)padop;
4108 padop->op_flags = (U8)flags;
4109 if (PL_opargs[type] & OA_RETSCALAR)
4111 if (PL_opargs[type] & OA_TARGET)
4112 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4113 return CHECKOP(type, padop);
4116 #endif /* !USE_ITHREADS */
4119 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4121 Constructs, checks, and returns an op of any type that involves an
4122 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4123 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4124 reference; calling this function does not transfer ownership of any
4131 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4135 PERL_ARGS_ASSERT_NEWGVOP;
4139 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4141 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4146 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4148 Constructs, checks, and returns an op of any type that involves an
4149 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4150 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4151 must have been allocated using L</PerlMemShared_malloc>; the memory will
4152 be freed when the op is destroyed.
4158 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4163 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4164 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4166 NewOp(1101, pvop, 1, PVOP);
4167 pvop->op_type = (OPCODE)type;
4168 pvop->op_ppaddr = PL_ppaddr[type];
4170 pvop->op_next = (OP*)pvop;
4171 pvop->op_flags = (U8)flags;
4172 if (PL_opargs[type] & OA_RETSCALAR)
4174 if (PL_opargs[type] & OA_TARGET)
4175 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4176 return CHECKOP(type, pvop);
4184 Perl_package(pTHX_ OP *o)
4187 SV *const sv = cSVOPo->op_sv;
4192 PERL_ARGS_ASSERT_PACKAGE;
4194 save_hptr(&PL_curstash);
4195 save_item(PL_curstname);
4197 PL_curstash = gv_stashsv(sv, GV_ADD);
4199 sv_setsv(PL_curstname, sv);
4201 PL_hints |= HINT_BLOCK_SCOPE;
4202 PL_parser->copline = NOLINE;
4203 PL_parser->expect = XSTATE;
4208 if (!PL_madskills) {
4213 pegop = newOP(OP_NULL,0);
4214 op_getmad(o,pegop,'P');
4220 Perl_package_version( pTHX_ OP *v )
4223 U32 savehints = PL_hints;
4224 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4225 PL_hints &= ~HINT_STRICT_VARS;
4226 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4227 PL_hints = savehints;
4236 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4243 OP *pegop = newOP(OP_NULL,0);
4245 SV *use_version = NULL;
4247 PERL_ARGS_ASSERT_UTILIZE;
4249 if (idop->op_type != OP_CONST)
4250 Perl_croak(aTHX_ "Module name must be constant");
4253 op_getmad(idop,pegop,'U');
4258 SV * const vesv = ((SVOP*)version)->op_sv;
4261 op_getmad(version,pegop,'V');
4262 if (!arg && !SvNIOKp(vesv)) {
4269 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4270 Perl_croak(aTHX_ "Version number must be a constant number");
4272 /* Make copy of idop so we don't free it twice */
4273 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4275 /* Fake up a method call to VERSION */
4276 meth = newSVpvs_share("VERSION");
4277 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4278 op_append_elem(OP_LIST,
4279 op_prepend_elem(OP_LIST, pack, list(version)),
4280 newSVOP(OP_METHOD_NAMED, 0, meth)));
4284 /* Fake up an import/unimport */
4285 if (arg && arg->op_type == OP_STUB) {
4287 op_getmad(arg,pegop,'S');
4288 imop = arg; /* no import on explicit () */
4290 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4291 imop = NULL; /* use 5.0; */
4293 use_version = ((SVOP*)idop)->op_sv;
4295 idop->op_private |= OPpCONST_NOVER;
4301 op_getmad(arg,pegop,'A');
4303 /* Make copy of idop so we don't free it twice */
4304 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4306 /* Fake up a method call to import/unimport */
4308 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4309 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4310 op_append_elem(OP_LIST,
4311 op_prepend_elem(OP_LIST, pack, list(arg)),
4312 newSVOP(OP_METHOD_NAMED, 0, meth)));
4315 /* Fake up the BEGIN {}, which does its thing immediately. */
4317 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4320 op_append_elem(OP_LINESEQ,
4321 op_append_elem(OP_LINESEQ,
4322 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4323 newSTATEOP(0, NULL, veop)),
4324 newSTATEOP(0, NULL, imop) ));
4327 /* If we request a version >= 5.9.5, load feature.pm with the
4328 * feature bundle that corresponds to the required version. */
4329 use_version = sv_2mortal(new_version(use_version));
4331 if (vcmp(use_version,
4332 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4333 SV *const importsv = vnormal(use_version);
4334 *SvPVX_mutable(importsv) = ':';
4335 ENTER_with_name("load_feature");
4336 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4337 LEAVE_with_name("load_feature");
4339 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4340 if (vcmp(use_version,
4341 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4342 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4346 /* The "did you use incorrect case?" warning used to be here.
4347 * The problem is that on case-insensitive filesystems one
4348 * might get false positives for "use" (and "require"):
4349 * "use Strict" or "require CARP" will work. This causes
4350 * portability problems for the script: in case-strict
4351 * filesystems the script will stop working.
4353 * The "incorrect case" warning checked whether "use Foo"
4354 * imported "Foo" to your namespace, but that is wrong, too:
4355 * there is no requirement nor promise in the language that
4356 * a Foo.pm should or would contain anything in package "Foo".
4358 * There is very little Configure-wise that can be done, either:
4359 * the case-sensitivity of the build filesystem of Perl does not
4360 * help in guessing the case-sensitivity of the runtime environment.
4363 PL_hints |= HINT_BLOCK_SCOPE;
4364 PL_parser->copline = NOLINE;
4365 PL_parser->expect = XSTATE;
4366 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4367 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4371 if (!PL_madskills) {
4372 /* FIXME - don't allocate pegop if !PL_madskills */
4381 =head1 Embedding Functions
4383 =for apidoc load_module
4385 Loads the module whose name is pointed to by the string part of name.
4386 Note that the actual module name, not its filename, should be given.
4387 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4388 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4389 (or 0 for no flags). ver, if specified, provides version semantics
4390 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4391 arguments can be used to specify arguments to the module's import()
4392 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4393 terminated with a final NULL pointer. Note that this list can only
4394 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4395 Otherwise at least a single NULL pointer to designate the default
4396 import list is required.
4401 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4405 PERL_ARGS_ASSERT_LOAD_MODULE;
4407 va_start(args, ver);
4408 vload_module(flags, name, ver, &args);
4412 #ifdef PERL_IMPLICIT_CONTEXT
4414 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4418 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4419 va_start(args, ver);
4420 vload_module(flags, name, ver, &args);
4426 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4430 OP * const modname = newSVOP(OP_CONST, 0, name);
4432 PERL_ARGS_ASSERT_VLOAD_MODULE;
4434 modname->op_private |= OPpCONST_BARE;
4436 veop = newSVOP(OP_CONST, 0, ver);
4440 if (flags & PERL_LOADMOD_NOIMPORT) {
4441 imop = sawparens(newNULLLIST());
4443 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4444 imop = va_arg(*args, OP*);
4449 sv = va_arg(*args, SV*);
4451 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4452 sv = va_arg(*args, SV*);
4456 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4457 * that it has a PL_parser to play with while doing that, and also
4458 * that it doesn't mess with any existing parser, by creating a tmp
4459 * new parser with lex_start(). This won't actually be used for much,
4460 * since pp_require() will create another parser for the real work. */
4463 SAVEVPTR(PL_curcop);
4464 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4465 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4466 veop, modname, imop);
4471 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4477 PERL_ARGS_ASSERT_DOFILE;
4479 if (!force_builtin) {
4480 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4481 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4482 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4483 gv = gvp ? *gvp : NULL;
4487 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4488 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4489 op_append_elem(OP_LIST, term,
4490 scalar(newUNOP(OP_RV2CV, 0,
4491 newGVOP(OP_GV, 0, gv))))));
4494 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4500 =head1 Optree construction
4502 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4504 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4505 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4506 be set automatically, and, shifted up eight bits, the eight bits of
4507 C<op_private>, except that the bit with value 1 or 2 is automatically
4508 set as required. I<listval> and I<subscript> supply the parameters of
4509 the slice; they are consumed by this function and become part of the
4510 constructed op tree.
4516 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4518 return newBINOP(OP_LSLICE, flags,
4519 list(force_list(subscript)),
4520 list(force_list(listval)) );
4524 S_is_list_assignment(pTHX_ register const OP *o)
4532 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4533 o = cUNOPo->op_first;
4535 flags = o->op_flags;
4537 if (type == OP_COND_EXPR) {
4538 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4539 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4544 yyerror("Assignment to both a list and a scalar");
4548 if (type == OP_LIST &&
4549 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4550 o->op_private & OPpLVAL_INTRO)
4553 if (type == OP_LIST || flags & OPf_PARENS ||
4554 type == OP_RV2AV || type == OP_RV2HV ||
4555 type == OP_ASLICE || type == OP_HSLICE)
4558 if (type == OP_PADAV || type == OP_PADHV)
4561 if (type == OP_RV2SV)
4568 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4570 Constructs, checks, and returns an assignment op. I<left> and I<right>
4571 supply the parameters of the assignment; they are consumed by this
4572 function and become part of the constructed op tree.
4574 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4575 a suitable conditional optree is constructed. If I<optype> is the opcode
4576 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4577 performs the binary operation and assigns the result to the left argument.
4578 Either way, if I<optype> is non-zero then I<flags> has no effect.
4580 If I<optype> is zero, then a plain scalar or list assignment is
4581 constructed. Which type of assignment it is is automatically determined.
4582 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4583 will be set automatically, and, shifted up eight bits, the eight bits
4584 of C<op_private>, except that the bit with value 1 or 2 is automatically
4591 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4597 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4598 return newLOGOP(optype, 0,
4599 op_lvalue(scalar(left), optype),
4600 newUNOP(OP_SASSIGN, 0, scalar(right)));
4603 return newBINOP(optype, OPf_STACKED,
4604 op_lvalue(scalar(left), optype), scalar(right));
4608 if (is_list_assignment(left)) {
4609 static const char no_list_state[] = "Initialization of state variables"
4610 " in list context currently forbidden";
4612 bool maybe_common_vars = TRUE;
4615 /* Grandfathering $[ assignment here. Bletch.*/
4616 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4617 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4618 left = op_lvalue(left, OP_AASSIGN);
4621 else if (left->op_type == OP_CONST) {
4622 deprecate("assignment to $[");
4624 /* Result of assignment is always 1 (or we'd be dead already) */
4625 return newSVOP(OP_CONST, 0, newSViv(1));
4627 curop = list(force_list(left));
4628 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4629 o->op_private = (U8)(0 | (flags >> 8));
4631 if ((left->op_type == OP_LIST
4632 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4634 OP* lop = ((LISTOP*)left)->op_first;
4635 maybe_common_vars = FALSE;
4637 if (lop->op_type == OP_PADSV ||
4638 lop->op_type == OP_PADAV ||
4639 lop->op_type == OP_PADHV ||
4640 lop->op_type == OP_PADANY) {
4641 if (!(lop->op_private & OPpLVAL_INTRO))
4642 maybe_common_vars = TRUE;
4644 if (lop->op_private & OPpPAD_STATE) {
4645 if (left->op_private & OPpLVAL_INTRO) {
4646 /* Each variable in state($a, $b, $c) = ... */
4649 /* Each state variable in
4650 (state $a, my $b, our $c, $d, undef) = ... */
4652 yyerror(no_list_state);
4654 /* Each my variable in
4655 (state $a, my $b, our $c, $d, undef) = ... */
4657 } else if (lop->op_type == OP_UNDEF ||
4658 lop->op_type == OP_PUSHMARK) {
4659 /* undef may be interesting in
4660 (state $a, undef, state $c) */
4662 /* Other ops in the list. */
4663 maybe_common_vars = TRUE;
4665 lop = lop->op_sibling;
4668 else if ((left->op_private & OPpLVAL_INTRO)
4669 && ( left->op_type == OP_PADSV
4670 || left->op_type == OP_PADAV
4671 || left->op_type == OP_PADHV
4672 || left->op_type == OP_PADANY))
4674 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4675 if (left->op_private & OPpPAD_STATE) {
4676 /* All single variable list context state assignments, hence
4686 yyerror(no_list_state);
4690 /* PL_generation sorcery:
4691 * an assignment like ($a,$b) = ($c,$d) is easier than
4692 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4693 * To detect whether there are common vars, the global var
4694 * PL_generation is incremented for each assign op we compile.
4695 * Then, while compiling the assign op, we run through all the
4696 * variables on both sides of the assignment, setting a spare slot
4697 * in each of them to PL_generation. If any of them already have
4698 * that value, we know we've got commonality. We could use a
4699 * single bit marker, but then we'd have to make 2 passes, first
4700 * to clear the flag, then to test and set it. To find somewhere
4701 * to store these values, evil chicanery is done with SvUVX().
4704 if (maybe_common_vars) {
4707 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4708 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4709 if (curop->op_type == OP_GV) {
4710 GV *gv = cGVOPx_gv(curop);
4712 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4714 GvASSIGN_GENERATION_set(gv, PL_generation);
4716 else if (curop->op_type == OP_PADSV ||
4717 curop->op_type == OP_PADAV ||
4718 curop->op_type == OP_PADHV ||
4719 curop->op_type == OP_PADANY)
4721 if (PAD_COMPNAME_GEN(curop->op_targ)
4722 == (STRLEN)PL_generation)
4724 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4727 else if (curop->op_type == OP_RV2CV)
4729 else if (curop->op_type == OP_RV2SV ||
4730 curop->op_type == OP_RV2AV ||
4731 curop->op_type == OP_RV2HV ||
4732 curop->op_type == OP_RV2GV) {
4733 if (lastop->op_type != OP_GV) /* funny deref? */
4736 else if (curop->op_type == OP_PUSHRE) {
4738 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4739 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4741 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4743 GvASSIGN_GENERATION_set(gv, PL_generation);
4747 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4750 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4752 GvASSIGN_GENERATION_set(gv, PL_generation);
4762 o->op_private |= OPpASSIGN_COMMON;
4765 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4766 OP* tmpop = ((LISTOP*)right)->op_first;
4767 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4768 PMOP * const pm = (PMOP*)tmpop;
4769 if (left->op_type == OP_RV2AV &&
4770 !(left->op_private & OPpLVAL_INTRO) &&
4771 !(o->op_private & OPpASSIGN_COMMON) )
4773 tmpop = ((UNOP*)left)->op_first;
4774 if (tmpop->op_type == OP_GV
4776 && !pm->op_pmreplrootu.op_pmtargetoff
4778 && !pm->op_pmreplrootu.op_pmtargetgv
4782 pm->op_pmreplrootu.op_pmtargetoff
4783 = cPADOPx(tmpop)->op_padix;
4784 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4786 pm->op_pmreplrootu.op_pmtargetgv
4787 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4788 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4790 pm->op_pmflags |= PMf_ONCE;
4791 tmpop = cUNOPo->op_first; /* to list (nulled) */
4792 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4793 tmpop->op_sibling = NULL; /* don't free split */
4794 right->op_next = tmpop->op_next; /* fix starting loc */
4795 op_free(o); /* blow off assign */
4796 right->op_flags &= ~OPf_WANT;
4797 /* "I don't know and I don't care." */
4802 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4803 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4805 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4806 if (SvIOK(sv) && SvIVX(sv) == 0)
4807 sv_setiv(sv, PL_modcount+1);
4815 right = newOP(OP_UNDEF, 0);
4816 if (right->op_type == OP_READLINE) {
4817 right->op_flags |= OPf_STACKED;
4818 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4822 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4823 o = newBINOP(OP_SASSIGN, flags,
4824 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4828 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4829 deprecate("assignment to $[");
4831 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4832 o->op_private |= OPpCONST_ARYBASE;
4840 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4842 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4843 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4844 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4845 If I<label> is non-null, it supplies the name of a label to attach to
4846 the state op; this function takes ownership of the memory pointed at by
4847 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4850 If I<o> is null, the state op is returned. Otherwise the state op is
4851 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4852 is consumed by this function and becomes part of the returned op tree.
4858 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4861 const U32 seq = intro_my();
4864 NewOp(1101, cop, 1, COP);
4865 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4866 cop->op_type = OP_DBSTATE;
4867 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4870 cop->op_type = OP_NEXTSTATE;
4871 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4873 cop->op_flags = (U8)flags;
4874 CopHINTS_set(cop, PL_hints);
4876 cop->op_private |= NATIVE_HINTS;
4878 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4879 cop->op_next = (OP*)cop;
4882 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4883 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4885 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4886 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4888 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4890 PL_hints |= HINT_BLOCK_SCOPE;
4891 /* It seems that we need to defer freeing this pointer, as other parts
4892 of the grammar end up wanting to copy it after this op has been
4897 if (PL_parser && PL_parser->copline == NOLINE)
4898 CopLINE_set(cop, CopLINE(PL_curcop));
4900 CopLINE_set(cop, PL_parser->copline);
4902 PL_parser->copline = NOLINE;
4905 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4907 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4909 CopSTASH_set(cop, PL_curstash);
4911 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4912 /* this line can have a breakpoint - store the cop in IV */
4913 AV *av = CopFILEAVx(PL_curcop);
4915 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4916 if (svp && *svp != &PL_sv_undef ) {
4917 (void)SvIOK_on(*svp);
4918 SvIV_set(*svp, PTR2IV(cop));
4923 if (flags & OPf_SPECIAL)
4925 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4929 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4931 Constructs, checks, and returns a logical (flow control) op. I<type>
4932 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4933 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4934 the eight bits of C<op_private>, except that the bit with value 1 is
4935 automatically set. I<first> supplies the expression controlling the
4936 flow, and I<other> supplies the side (alternate) chain of ops; they are
4937 consumed by this function and become part of the constructed op tree.
4943 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4947 PERL_ARGS_ASSERT_NEWLOGOP;
4949 return new_logop(type, flags, &first, &other);
4953 S_search_const(pTHX_ OP *o)
4955 PERL_ARGS_ASSERT_SEARCH_CONST;
4957 switch (o->op_type) {
4961 if (o->op_flags & OPf_KIDS)
4962 return search_const(cUNOPo->op_first);
4969 if (!(o->op_flags & OPf_KIDS))
4971 kid = cLISTOPo->op_first;
4973 switch (kid->op_type) {
4977 kid = kid->op_sibling;
4980 if (kid != cLISTOPo->op_last)
4986 kid = cLISTOPo->op_last;
4988 return search_const(kid);
4996 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5004 int prepend_not = 0;
5006 PERL_ARGS_ASSERT_NEW_LOGOP;
5011 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5012 return newBINOP(type, flags, scalar(first), scalar(other));
5014 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5016 scalarboolean(first);
5017 /* optimize AND and OR ops that have NOTs as children */
5018 if (first->op_type == OP_NOT
5019 && (first->op_flags & OPf_KIDS)
5020 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5021 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5023 if (type == OP_AND || type == OP_OR) {
5029 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5031 prepend_not = 1; /* prepend a NOT op later */
5035 /* search for a constant op that could let us fold the test */
5036 if ((cstop = search_const(first))) {
5037 if (cstop->op_private & OPpCONST_STRICT)
5038 no_bareword_allowed(cstop);
5039 else if ((cstop->op_private & OPpCONST_BARE))
5040 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5041 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5042 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5043 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5045 if (other->op_type == OP_CONST)
5046 other->op_private |= OPpCONST_SHORTCIRCUIT;
5048 OP *newop = newUNOP(OP_NULL, 0, other);
5049 op_getmad(first, newop, '1');
5050 newop->op_targ = type; /* set "was" field */
5054 if (other->op_type == OP_LEAVE)
5055 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5056 else if (other->op_type == OP_MATCH
5057 || other->op_type == OP_SUBST
5058 || other->op_type == OP_TRANSR
5059 || other->op_type == OP_TRANS)
5060 /* Mark the op as being unbindable with =~ */
5061 other->op_flags |= OPf_SPECIAL;
5065 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5066 const OP *o2 = other;
5067 if ( ! (o2->op_type == OP_LIST
5068 && (( o2 = cUNOPx(o2)->op_first))
5069 && o2->op_type == OP_PUSHMARK
5070 && (( o2 = o2->op_sibling)) )
5073 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5074 || o2->op_type == OP_PADHV)
5075 && o2->op_private & OPpLVAL_INTRO
5076 && !(o2->op_private & OPpPAD_STATE))
5078 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5079 "Deprecated use of my() in false conditional");
5083 if (first->op_type == OP_CONST)
5084 first->op_private |= OPpCONST_SHORTCIRCUIT;
5086 first = newUNOP(OP_NULL, 0, first);
5087 op_getmad(other, first, '2');
5088 first->op_targ = type; /* set "was" field */
5095 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5096 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5098 const OP * const k1 = ((UNOP*)first)->op_first;
5099 const OP * const k2 = k1->op_sibling;
5101 switch (first->op_type)
5104 if (k2 && k2->op_type == OP_READLINE
5105 && (k2->op_flags & OPf_STACKED)
5106 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5108 warnop = k2->op_type;
5113 if (k1->op_type == OP_READDIR
5114 || k1->op_type == OP_GLOB
5115 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5116 || k1->op_type == OP_EACH
5117 || k1->op_type == OP_AEACH)
5119 warnop = ((k1->op_type == OP_NULL)
5120 ? (OPCODE)k1->op_targ : k1->op_type);
5125 const line_t oldline = CopLINE(PL_curcop);
5126 CopLINE_set(PL_curcop, PL_parser->copline);
5127 Perl_warner(aTHX_ packWARN(WARN_MISC),
5128 "Value of %s%s can be \"0\"; test with defined()",
5130 ((warnop == OP_READLINE || warnop == OP_GLOB)
5131 ? " construct" : "() operator"));
5132 CopLINE_set(PL_curcop, oldline);
5139 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5140 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5142 NewOp(1101, logop, 1, LOGOP);
5144 logop->op_type = (OPCODE)type;
5145 logop->op_ppaddr = PL_ppaddr[type];
5146 logop->op_first = first;
5147 logop->op_flags = (U8)(flags | OPf_KIDS);
5148 logop->op_other = LINKLIST(other);
5149 logop->op_private = (U8)(1 | (flags >> 8));
5151 /* establish postfix order */
5152 logop->op_next = LINKLIST(first);
5153 first->op_next = (OP*)logop;
5154 first->op_sibling = other;
5156 CHECKOP(type,logop);
5158 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5165 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5167 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5168 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5169 will be set automatically, and, shifted up eight bits, the eight bits of
5170 C<op_private>, except that the bit with value 1 is automatically set.
5171 I<first> supplies the expression selecting between the two branches,
5172 and I<trueop> and I<falseop> supply the branches; they are consumed by
5173 this function and become part of the constructed op tree.
5179 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5187 PERL_ARGS_ASSERT_NEWCONDOP;
5190 return newLOGOP(OP_AND, 0, first, trueop);
5192 return newLOGOP(OP_OR, 0, first, falseop);
5194 scalarboolean(first);
5195 if ((cstop = search_const(first))) {
5196 /* Left or right arm of the conditional? */
5197 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5198 OP *live = left ? trueop : falseop;
5199 OP *const dead = left ? falseop : trueop;
5200 if (cstop->op_private & OPpCONST_BARE &&
5201 cstop->op_private & OPpCONST_STRICT) {
5202 no_bareword_allowed(cstop);
5205 /* This is all dead code when PERL_MAD is not defined. */
5206 live = newUNOP(OP_NULL, 0, live);
5207 op_getmad(first, live, 'C');
5208 op_getmad(dead, live, left ? 'e' : 't');
5213 if (live->op_type == OP_LEAVE)
5214 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5215 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5216 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5217 /* Mark the op as being unbindable with =~ */
5218 live->op_flags |= OPf_SPECIAL;
5221 NewOp(1101, logop, 1, LOGOP);
5222 logop->op_type = OP_COND_EXPR;
5223 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5224 logop->op_first = first;
5225 logop->op_flags = (U8)(flags | OPf_KIDS);
5226 logop->op_private = (U8)(1 | (flags >> 8));
5227 logop->op_other = LINKLIST(trueop);
5228 logop->op_next = LINKLIST(falseop);
5230 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5233 /* establish postfix order */
5234 start = LINKLIST(first);
5235 first->op_next = (OP*)logop;
5237 first->op_sibling = trueop;
5238 trueop->op_sibling = falseop;
5239 o = newUNOP(OP_NULL, 0, (OP*)logop);
5241 trueop->op_next = falseop->op_next = o;
5248 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5250 Constructs and returns a C<range> op, with subordinate C<flip> and
5251 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5252 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5253 for both the C<flip> and C<range> ops, except that the bit with value
5254 1 is automatically set. I<left> and I<right> supply the expressions
5255 controlling the endpoints of the range; they are consumed by this function
5256 and become part of the constructed op tree.
5262 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5271 PERL_ARGS_ASSERT_NEWRANGE;
5273 NewOp(1101, range, 1, LOGOP);
5275 range->op_type = OP_RANGE;
5276 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5277 range->op_first = left;
5278 range->op_flags = OPf_KIDS;
5279 leftstart = LINKLIST(left);
5280 range->op_other = LINKLIST(right);
5281 range->op_private = (U8)(1 | (flags >> 8));
5283 left->op_sibling = right;
5285 range->op_next = (OP*)range;
5286 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5287 flop = newUNOP(OP_FLOP, 0, flip);
5288 o = newUNOP(OP_NULL, 0, flop);
5290 range->op_next = leftstart;
5292 left->op_next = flip;
5293 right->op_next = flop;
5295 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5296 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5297 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5298 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5300 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5301 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5304 if (!flip->op_private || !flop->op_private)
5305 LINKLIST(o); /* blow off optimizer unless constant */
5311 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5313 Constructs, checks, and returns an op tree expressing a loop. This is
5314 only a loop in the control flow through the op tree; it does not have
5315 the heavyweight loop structure that allows exiting the loop by C<last>
5316 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5317 top-level op, except that some bits will be set automatically as required.
5318 I<expr> supplies the expression controlling loop iteration, and I<block>
5319 supplies the body of the loop; they are consumed by this function and
5320 become part of the constructed op tree. I<debuggable> is currently
5321 unused and should always be 1.
5327 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5332 const bool once = block && block->op_flags & OPf_SPECIAL &&
5333 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5335 PERL_UNUSED_ARG(debuggable);
5338 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5339 return block; /* do {} while 0 does once */
5340 if (expr->op_type == OP_READLINE
5341 || expr->op_type == OP_READDIR
5342 || expr->op_type == OP_GLOB
5343 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5344 expr = newUNOP(OP_DEFINED, 0,
5345 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5346 } else if (expr->op_flags & OPf_KIDS) {
5347 const OP * const k1 = ((UNOP*)expr)->op_first;
5348 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5349 switch (expr->op_type) {
5351 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5352 && (k2->op_flags & OPf_STACKED)
5353 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5354 expr = newUNOP(OP_DEFINED, 0, expr);
5358 if (k1 && (k1->op_type == OP_READDIR
5359 || k1->op_type == OP_GLOB
5360 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5361 || k1->op_type == OP_EACH
5362 || k1->op_type == OP_AEACH))
5363 expr = newUNOP(OP_DEFINED, 0, expr);
5369 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5370 * op, in listop. This is wrong. [perl #27024] */
5372 block = newOP(OP_NULL, 0);
5373 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5374 o = new_logop(OP_AND, 0, &expr, &listop);
5377 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5379 if (once && o != listop)
5380 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5383 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5385 o->op_flags |= flags;
5387 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5392 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5394 Constructs, checks, and returns an op tree expressing a C<while> loop.
5395 This is a heavyweight loop, with structure that allows exiting the loop
5396 by C<last> and suchlike.
5398 I<loop> is an optional preconstructed C<enterloop> op to use in the
5399 loop; if it is null then a suitable op will be constructed automatically.
5400 I<expr> supplies the loop's controlling expression. I<block> supplies the
5401 main body of the loop, and I<cont> optionally supplies a C<continue> block
5402 that operates as a second half of the body. All of these optree inputs
5403 are consumed by this function and become part of the constructed op tree.
5405 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5406 op and, shifted up eight bits, the eight bits of C<op_private> for
5407 the C<leaveloop> op, except that (in both cases) some bits will be set
5408 automatically. I<debuggable> is currently unused and should always be 1.
5409 I<has_my> can be supplied as true to force the
5410 loop body to be enclosed in its own scope.
5416 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5417 OP *expr, OP *block, OP *cont, I32 has_my)
5426 PERL_UNUSED_ARG(debuggable);
5429 if (expr->op_type == OP_READLINE
5430 || expr->op_type == OP_READDIR
5431 || expr->op_type == OP_GLOB
5432 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5433 expr = newUNOP(OP_DEFINED, 0,
5434 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5435 } else if (expr->op_flags & OPf_KIDS) {
5436 const OP * const k1 = ((UNOP*)expr)->op_first;
5437 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5438 switch (expr->op_type) {
5440 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5441 && (k2->op_flags & OPf_STACKED)
5442 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5443 expr = newUNOP(OP_DEFINED, 0, expr);
5447 if (k1 && (k1->op_type == OP_READDIR
5448 || k1->op_type == OP_GLOB
5449 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5450 || k1->op_type == OP_EACH
5451 || k1->op_type == OP_AEACH))
5452 expr = newUNOP(OP_DEFINED, 0, expr);
5459 block = newOP(OP_NULL, 0);
5460 else if (cont || has_my) {
5461 block = op_scope(block);
5465 next = LINKLIST(cont);
5468 OP * const unstack = newOP(OP_UNSTACK, 0);
5471 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5475 listop = op_append_list(OP_LINESEQ, block, cont);
5477 redo = LINKLIST(listop);
5481 o = new_logop(OP_AND, 0, &expr, &listop);
5482 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5483 op_free(expr); /* oops, it's a while (0) */
5485 return NULL; /* listop already freed by new_logop */
5488 ((LISTOP*)listop)->op_last->op_next =
5489 (o == listop ? redo : LINKLIST(o));
5495 NewOp(1101,loop,1,LOOP);
5496 loop->op_type = OP_ENTERLOOP;
5497 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5498 loop->op_private = 0;
5499 loop->op_next = (OP*)loop;
5502 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5504 loop->op_redoop = redo;
5505 loop->op_lastop = o;
5506 o->op_private |= loopflags;
5509 loop->op_nextop = next;
5511 loop->op_nextop = o;
5513 o->op_flags |= flags;
5514 o->op_private |= (flags >> 8);
5519 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5521 Constructs, checks, and returns an op tree expressing a C<foreach>
5522 loop (iteration through a list of values). This is a heavyweight loop,
5523 with structure that allows exiting the loop by C<last> and suchlike.
5525 I<sv> optionally supplies the variable that will be aliased to each
5526 item in turn; if null, it defaults to C<$_> (either lexical or global).
5527 I<expr> supplies the list of values to iterate over. I<block> supplies
5528 the main body of the loop, and I<cont> optionally supplies a C<continue>
5529 block that operates as a second half of the body. All of these optree
5530 inputs are consumed by this function and become part of the constructed
5533 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5534 op and, shifted up eight bits, the eight bits of C<op_private> for
5535 the C<leaveloop> op, except that (in both cases) some bits will be set
5542 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5547 PADOFFSET padoff = 0;
5552 PERL_ARGS_ASSERT_NEWFOROP;
5555 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5556 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5557 sv->op_type = OP_RV2GV;
5558 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5560 /* The op_type check is needed to prevent a possible segfault
5561 * if the loop variable is undeclared and 'strict vars' is in
5562 * effect. This is illegal but is nonetheless parsed, so we
5563 * may reach this point with an OP_CONST where we're expecting
5566 if (cUNOPx(sv)->op_first->op_type == OP_GV
5567 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5568 iterpflags |= OPpITER_DEF;
5570 else if (sv->op_type == OP_PADSV) { /* private variable */
5571 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5572 padoff = sv->op_targ;
5582 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5584 SV *const namesv = PAD_COMPNAME_SV(padoff);
5586 const char *const name = SvPV_const(namesv, len);
5588 if (len == 2 && name[0] == '$' && name[1] == '_')
5589 iterpflags |= OPpITER_DEF;
5593 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5594 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5595 sv = newGVOP(OP_GV, 0, PL_defgv);
5600 iterpflags |= OPpITER_DEF;
5602 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5603 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5604 iterflags |= OPf_STACKED;
5606 else if (expr->op_type == OP_NULL &&
5607 (expr->op_flags & OPf_KIDS) &&
5608 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5610 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5611 * set the STACKED flag to indicate that these values are to be
5612 * treated as min/max values by 'pp_iterinit'.
5614 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5615 LOGOP* const range = (LOGOP*) flip->op_first;
5616 OP* const left = range->op_first;
5617 OP* const right = left->op_sibling;
5620 range->op_flags &= ~OPf_KIDS;
5621 range->op_first = NULL;
5623 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5624 listop->op_first->op_next = range->op_next;
5625 left->op_next = range->op_other;
5626 right->op_next = (OP*)listop;
5627 listop->op_next = listop->op_first;
5630 op_getmad(expr,(OP*)listop,'O');
5634 expr = (OP*)(listop);
5636 iterflags |= OPf_STACKED;
5639 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5642 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5643 op_append_elem(OP_LIST, expr, scalar(sv))));
5644 assert(!loop->op_next);
5645 /* for my $x () sets OPpLVAL_INTRO;
5646 * for our $x () sets OPpOUR_INTRO */
5647 loop->op_private = (U8)iterpflags;
5648 #ifdef PL_OP_SLAB_ALLOC
5651 NewOp(1234,tmp,1,LOOP);
5652 Copy(loop,tmp,1,LISTOP);
5653 S_op_destroy(aTHX_ (OP*)loop);
5657 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5659 loop->op_targ = padoff;
5660 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5662 op_getmad(madsv, (OP*)loop, 'v');
5667 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5669 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5670 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5671 determining the target of the op; it is consumed by this function and
5672 become part of the constructed op tree.
5678 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5683 PERL_ARGS_ASSERT_NEWLOOPEX;
5685 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5687 if (type != OP_GOTO || label->op_type == OP_CONST) {
5688 /* "last()" means "last" */
5689 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5690 o = newOP(type, OPf_SPECIAL);
5692 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5693 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5697 op_getmad(label,o,'L');
5703 /* Check whether it's going to be a goto &function */
5704 if (label->op_type == OP_ENTERSUB
5705 && !(label->op_flags & OPf_STACKED))
5706 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5707 o = newUNOP(type, OPf_STACKED, label);
5709 PL_hints |= HINT_BLOCK_SCOPE;
5713 /* if the condition is a literal array or hash
5714 (or @{ ... } etc), make a reference to it.
5717 S_ref_array_or_hash(pTHX_ OP *cond)
5720 && (cond->op_type == OP_RV2AV
5721 || cond->op_type == OP_PADAV
5722 || cond->op_type == OP_RV2HV
5723 || cond->op_type == OP_PADHV))
5725 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5728 && (cond->op_type == OP_ASLICE
5729 || cond->op_type == OP_HSLICE)) {
5731 /* anonlist now needs a list from this op, was previously used in
5733 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5734 cond->op_flags |= OPf_WANT_LIST;
5736 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5743 /* These construct the optree fragments representing given()
5746 entergiven and enterwhen are LOGOPs; the op_other pointer
5747 points up to the associated leave op. We need this so we
5748 can put it in the context and make break/continue work.
5749 (Also, of course, pp_enterwhen will jump straight to
5750 op_other if the match fails.)
5754 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5755 I32 enter_opcode, I32 leave_opcode,
5756 PADOFFSET entertarg)
5762 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5764 NewOp(1101, enterop, 1, LOGOP);
5765 enterop->op_type = (Optype)enter_opcode;
5766 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5767 enterop->op_flags = (U8) OPf_KIDS;
5768 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5769 enterop->op_private = 0;
5771 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5774 enterop->op_first = scalar(cond);
5775 cond->op_sibling = block;
5777 o->op_next = LINKLIST(cond);
5778 cond->op_next = (OP *) enterop;
5781 /* This is a default {} block */
5782 enterop->op_first = block;
5783 enterop->op_flags |= OPf_SPECIAL;
5785 o->op_next = (OP *) enterop;
5788 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5789 entergiven and enterwhen both
5792 enterop->op_next = LINKLIST(block);
5793 block->op_next = enterop->op_other = o;
5798 /* Does this look like a boolean operation? For these purposes
5799 a boolean operation is:
5800 - a subroutine call [*]
5801 - a logical connective
5802 - a comparison operator
5803 - a filetest operator, with the exception of -s -M -A -C
5804 - defined(), exists() or eof()
5805 - /$re/ or $foo =~ /$re/
5807 [*] possibly surprising
5810 S_looks_like_bool(pTHX_ const OP *o)
5814 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5816 switch(o->op_type) {
5819 return looks_like_bool(cLOGOPo->op_first);
5823 looks_like_bool(cLOGOPo->op_first)
5824 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5829 o->op_flags & OPf_KIDS
5830 && looks_like_bool(cUNOPo->op_first));
5834 case OP_NOT: case OP_XOR:
5836 case OP_EQ: case OP_NE: case OP_LT:
5837 case OP_GT: case OP_LE: case OP_GE:
5839 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5840 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5842 case OP_SEQ: case OP_SNE: case OP_SLT:
5843 case OP_SGT: case OP_SLE: case OP_SGE:
5847 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5848 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5849 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5850 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5851 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5852 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5853 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5854 case OP_FTTEXT: case OP_FTBINARY:
5856 case OP_DEFINED: case OP_EXISTS:
5857 case OP_MATCH: case OP_EOF:
5864 /* Detect comparisons that have been optimized away */
5865 if (cSVOPo->op_sv == &PL_sv_yes
5866 || cSVOPo->op_sv == &PL_sv_no)
5879 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5881 Constructs, checks, and returns an op tree expressing a C<given> block.
5882 I<cond> supplies the expression that will be locally assigned to a lexical
5883 variable, and I<block> supplies the body of the C<given> construct; they
5884 are consumed by this function and become part of the constructed op tree.
5885 I<defsv_off> is the pad offset of the scalar lexical variable that will
5892 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5895 PERL_ARGS_ASSERT_NEWGIVENOP;
5896 return newGIVWHENOP(
5897 ref_array_or_hash(cond),
5899 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5904 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5906 Constructs, checks, and returns an op tree expressing a C<when> block.
5907 I<cond> supplies the test expression, and I<block> supplies the block
5908 that will be executed if the test evaluates to true; they are consumed
5909 by this function and become part of the constructed op tree. I<cond>
5910 will be interpreted DWIMically, often as a comparison against C<$_>,
5911 and may be null to generate a C<default> block.
5917 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5919 const bool cond_llb = (!cond || looks_like_bool(cond));
5922 PERL_ARGS_ASSERT_NEWWHENOP;
5927 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5929 scalar(ref_array_or_hash(cond)));
5932 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5936 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5939 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5941 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5942 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5943 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5944 || (p && (len != SvCUR(cv) /* Not the same length. */
5945 || memNE(p, SvPVX_const(cv), len))))
5946 && ckWARN_d(WARN_PROTOTYPE)) {
5947 SV* const msg = sv_newmortal();
5951 gv_efullname3(name = sv_newmortal(), gv, NULL);
5952 sv_setpvs(msg, "Prototype mismatch:");
5954 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5956 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5958 sv_catpvs(msg, ": none");
5959 sv_catpvs(msg, " vs ");
5961 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5963 sv_catpvs(msg, "none");
5964 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5968 static void const_sv_xsub(pTHX_ CV* cv);
5972 =head1 Optree Manipulation Functions
5974 =for apidoc cv_const_sv
5976 If C<cv> is a constant sub eligible for inlining. returns the constant
5977 value returned by the sub. Otherwise, returns NULL.
5979 Constant subs can be created with C<newCONSTSUB> or as described in
5980 L<perlsub/"Constant Functions">.
5985 Perl_cv_const_sv(pTHX_ const CV *const cv)
5987 PERL_UNUSED_CONTEXT;
5990 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5992 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5995 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5996 * Can be called in 3 ways:
5999 * look for a single OP_CONST with attached value: return the value
6001 * cv && CvCLONE(cv) && !CvCONST(cv)
6003 * examine the clone prototype, and if contains only a single
6004 * OP_CONST referencing a pad const, or a single PADSV referencing
6005 * an outer lexical, return a non-zero value to indicate the CV is
6006 * a candidate for "constizing" at clone time
6010 * We have just cloned an anon prototype that was marked as a const
6011 * candidate. Try to grab the current value, and in the case of
6012 * PADSV, ignore it if it has multiple references. Return the value.
6016 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6027 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6028 o = cLISTOPo->op_first->op_sibling;
6030 for (; o; o = o->op_next) {
6031 const OPCODE type = o->op_type;
6033 if (sv && o->op_next == o)
6035 if (o->op_next != o) {
6036 if (type == OP_NEXTSTATE
6037 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6038 || type == OP_PUSHMARK)
6040 if (type == OP_DBSTATE)
6043 if (type == OP_LEAVESUB || type == OP_RETURN)
6047 if (type == OP_CONST && cSVOPo->op_sv)
6049 else if (cv && type == OP_CONST) {
6050 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6054 else if (cv && type == OP_PADSV) {
6055 if (CvCONST(cv)) { /* newly cloned anon */
6056 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6057 /* the candidate should have 1 ref from this pad and 1 ref
6058 * from the parent */
6059 if (!sv || SvREFCNT(sv) != 2)
6066 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6067 sv = &PL_sv_undef; /* an arbitrary non-null value */
6082 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6085 /* This would be the return value, but the return cannot be reached. */
6086 OP* pegop = newOP(OP_NULL, 0);
6089 PERL_UNUSED_ARG(floor);
6099 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6101 NORETURN_FUNCTION_END;
6106 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6111 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6112 register CV *cv = NULL;
6114 /* If the subroutine has no body, no attributes, and no builtin attributes
6115 then it's just a sub declaration, and we may be able to get away with
6116 storing with a placeholder scalar in the symbol table, rather than a
6117 full GV and CV. If anything is present then it will take a full CV to
6119 const I32 gv_fetch_flags
6120 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6122 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6123 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6127 assert(proto->op_type == OP_CONST);
6128 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6134 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6136 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6137 SV * const sv = sv_newmortal();
6138 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6139 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6140 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6141 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6143 } else if (PL_curstash) {
6144 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6147 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6151 if (!PL_madskills) {
6160 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6161 maximum a prototype before. */
6162 if (SvTYPE(gv) > SVt_NULL) {
6163 if (!SvPOK((const SV *)gv)
6164 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6166 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6168 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6171 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6173 sv_setiv(MUTABLE_SV(gv), -1);
6175 SvREFCNT_dec(PL_compcv);
6176 cv = PL_compcv = NULL;
6180 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6182 if (!block || !ps || *ps || attrs
6183 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6185 || block->op_type == OP_NULL
6190 const_sv = op_const_sv(block, NULL);
6193 const bool exists = CvROOT(cv) || CvXSUB(cv);
6195 /* if the subroutine doesn't exist and wasn't pre-declared
6196 * with a prototype, assume it will be AUTOLOADed,
6197 * skipping the prototype check
6199 if (exists || SvPOK(cv))
6200 cv_ckproto_len(cv, gv, ps, ps_len);
6201 /* already defined (or promised)? */
6202 if (exists || GvASSUMECV(gv)) {
6205 || block->op_type == OP_NULL
6208 if (CvFLAGS(PL_compcv)) {
6209 /* might have had built-in attrs applied */
6210 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6211 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6212 && ckWARN(WARN_MISC))
6213 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6215 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6216 & ~(CVf_LVALUE * pureperl));
6218 if (attrs) goto attrs;
6219 /* just a "sub foo;" when &foo is already defined */
6220 SAVEFREESV(PL_compcv);
6225 && block->op_type != OP_NULL
6228 if (ckWARN(WARN_REDEFINE)
6230 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6232 const line_t oldline = CopLINE(PL_curcop);
6233 if (PL_parser && PL_parser->copline != NOLINE)
6234 CopLINE_set(PL_curcop, PL_parser->copline);
6235 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6236 CvCONST(cv) ? "Constant subroutine %s redefined"
6237 : "Subroutine %s redefined", name);
6238 CopLINE_set(PL_curcop, oldline);
6241 if (!PL_minus_c) /* keep old one around for madskills */
6244 /* (PL_madskills unset in used file.) */
6252 SvREFCNT_inc_simple_void_NN(const_sv);
6254 assert(!CvROOT(cv) && !CvCONST(cv));
6255 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6256 CvXSUBANY(cv).any_ptr = const_sv;
6257 CvXSUB(cv) = const_sv_xsub;
6263 cv = newCONSTSUB(NULL, name, const_sv);
6265 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6266 (CvGV(cv) && GvSTASH(CvGV(cv)))
6275 SvREFCNT_dec(PL_compcv);
6279 if (cv) { /* must reuse cv if autoloaded */
6280 /* transfer PL_compcv to cv */
6283 && block->op_type != OP_NULL
6286 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6287 AV *const temp_av = CvPADLIST(cv);
6288 CV *const temp_cv = CvOUTSIDE(cv);
6290 assert(!CvWEAKOUTSIDE(cv));
6291 assert(!CvCVGV_RC(cv));
6292 assert(CvGV(cv) == gv);
6295 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6296 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6297 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6298 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6299 CvOUTSIDE(PL_compcv) = temp_cv;
6300 CvPADLIST(PL_compcv) = temp_av;
6303 if (CvFILE(cv) && !CvISXSUB(cv)) {
6304 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6305 Safefree(CvFILE(cv));
6308 CvFILE_set_from_cop(cv, PL_curcop);
6309 CvSTASH_set(cv, PL_curstash);
6311 /* inner references to PL_compcv must be fixed up ... */
6312 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6313 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6314 ++PL_sub_generation;
6317 /* Might have had built-in attributes applied -- propagate them. */
6318 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6320 /* ... before we throw it away */
6321 SvREFCNT_dec(PL_compcv);
6329 if (strEQ(name, "import")) {
6330 PL_formfeed = MUTABLE_SV(cv);
6331 /* diag_listed_as: SKIPME */
6332 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6336 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6341 CvFILE_set_from_cop(cv, PL_curcop);
6342 CvSTASH_set(cv, PL_curstash);
6346 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6347 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6348 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6352 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6354 if (PL_parser && PL_parser->error_count) {
6358 const char *s = strrchr(name, ':');
6360 if (strEQ(s, "BEGIN")) {
6361 const char not_safe[] =
6362 "BEGIN not safe after errors--compilation aborted";
6363 if (PL_in_eval & EVAL_KEEPERR)
6364 Perl_croak(aTHX_ not_safe);
6366 /* force display of errors found but not reported */
6367 sv_catpv(ERRSV, not_safe);
6368 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6377 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6378 the debugger could be able to set a breakpoint in, so signal to
6379 pp_entereval that it should not throw away any saved lines at scope
6382 PL_breakable_sub_gen++;
6383 /* This makes sub {}; work as expected. */
6384 if (block->op_type == OP_STUB) {
6385 OP* const newblock = newSTATEOP(0, NULL, 0);
6387 op_getmad(block,newblock,'B');
6393 else block->op_attached = 1;
6394 CvROOT(cv) = CvLVALUE(cv)
6395 ? newUNOP(OP_LEAVESUBLV, 0,
6396 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6397 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6398 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6399 OpREFCNT_set(CvROOT(cv), 1);
6400 CvSTART(cv) = LINKLIST(CvROOT(cv));
6401 CvROOT(cv)->op_next = 0;
6402 CALL_PEEP(CvSTART(cv));
6404 /* now that optimizer has done its work, adjust pad values */
6406 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6409 assert(!CvCONST(cv));
6410 if (ps && !*ps && op_const_sv(block, cv))
6415 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6416 SV * const tmpstr = sv_newmortal();
6417 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6418 GV_ADDMULTI, SVt_PVHV);
6420 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6423 (long)CopLINE(PL_curcop));
6424 gv_efullname3(tmpstr, gv, NULL);
6425 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6426 SvCUR(tmpstr), sv, 0);
6427 hv = GvHVn(db_postponed);
6428 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6429 CV * const pcv = GvCV(db_postponed);
6435 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6440 if (name && ! (PL_parser && PL_parser->error_count))
6441 process_special_blocks(name, gv, cv);
6446 PL_parser->copline = NOLINE;
6452 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6455 const char *const colon = strrchr(fullname,':');
6456 const char *const name = colon ? colon + 1 : fullname;
6458 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6461 if (strEQ(name, "BEGIN")) {
6462 const I32 oldscope = PL_scopestack_ix;
6464 SAVECOPFILE(&PL_compiling);
6465 SAVECOPLINE(&PL_compiling);
6467 DEBUG_x( dump_sub(gv) );
6468 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6469 GvCV_set(gv,0); /* cv has been hijacked */
6470 call_list(oldscope, PL_beginav);
6472 PL_curcop = &PL_compiling;
6473 CopHINTS_set(&PL_compiling, PL_hints);
6480 if strEQ(name, "END") {
6481 DEBUG_x( dump_sub(gv) );
6482 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6485 } else if (*name == 'U') {
6486 if (strEQ(name, "UNITCHECK")) {
6487 /* It's never too late to run a unitcheck block */
6488 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6492 } else if (*name == 'C') {
6493 if (strEQ(name, "CHECK")) {
6495 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6496 "Too late to run CHECK block");
6497 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6501 } else if (*name == 'I') {
6502 if (strEQ(name, "INIT")) {
6504 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6505 "Too late to run INIT block");
6506 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6512 DEBUG_x( dump_sub(gv) );
6513 GvCV_set(gv,0); /* cv has been hijacked */
6518 =for apidoc newCONSTSUB
6520 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6521 eligible for inlining at compile-time.
6523 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6524 which won't be called if used as a destructor, but will suppress the overhead
6525 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6532 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6537 const char *const file = CopFILE(PL_curcop);
6539 SV *const temp_sv = CopFILESV(PL_curcop);
6540 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6545 if (IN_PERL_RUNTIME) {
6546 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6547 * an op shared between threads. Use a non-shared COP for our
6549 SAVEVPTR(PL_curcop);
6550 PL_curcop = &PL_compiling;
6552 SAVECOPLINE(PL_curcop);
6553 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6556 PL_hints &= ~HINT_BLOCK_SCOPE;
6559 SAVESPTR(PL_curstash);
6560 SAVECOPSTASH(PL_curcop);
6561 PL_curstash = stash;
6562 CopSTASH_set(PL_curcop,stash);
6565 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6566 and so doesn't get free()d. (It's expected to be from the C pre-
6567 processor __FILE__ directive). But we need a dynamically allocated one,
6568 and we need it to get freed. */
6569 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6570 XS_DYNAMIC_FILENAME);
6571 CvXSUBANY(cv).any_ptr = sv;
6576 CopSTASH_free(PL_curcop);
6584 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6585 const char *const filename, const char *const proto,
6588 CV *cv = newXS(name, subaddr, filename);
6590 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6592 if (flags & XS_DYNAMIC_FILENAME) {
6593 /* We need to "make arrangements" (ie cheat) to ensure that the
6594 filename lasts as long as the PVCV we just created, but also doesn't
6596 STRLEN filename_len = strlen(filename);
6597 STRLEN proto_and_file_len = filename_len;
6598 char *proto_and_file;
6602 proto_len = strlen(proto);
6603 proto_and_file_len += proto_len;
6605 Newx(proto_and_file, proto_and_file_len + 1, char);
6606 Copy(proto, proto_and_file, proto_len, char);
6607 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6610 proto_and_file = savepvn(filename, filename_len);
6613 /* This gets free()d. :-) */
6614 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6615 SV_HAS_TRAILING_NUL);
6617 /* This gives us the correct prototype, rather than one with the
6618 file name appended. */
6619 SvCUR_set(cv, proto_len);
6623 CvFILE(cv) = proto_and_file + proto_len;
6625 sv_setpv(MUTABLE_SV(cv), proto);
6631 =for apidoc U||newXS
6633 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6634 static storage, as it is used directly as CvFILE(), without a copy being made.
6640 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6643 GV * const gv = gv_fetchpv(name ? name :
6644 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6645 GV_ADDMULTI, SVt_PVCV);
6648 PERL_ARGS_ASSERT_NEWXS;
6651 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6653 if ((cv = (name ? GvCV(gv) : NULL))) {
6655 /* just a cached method */
6659 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6660 /* already defined (or promised) */
6661 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6662 if (ckWARN(WARN_REDEFINE)) {
6663 GV * const gvcv = CvGV(cv);
6665 HV * const stash = GvSTASH(gvcv);
6667 const char *redefined_name = HvNAME_get(stash);
6668 if ( strEQ(redefined_name,"autouse") ) {
6669 const line_t oldline = CopLINE(PL_curcop);
6670 if (PL_parser && PL_parser->copline != NOLINE)
6671 CopLINE_set(PL_curcop, PL_parser->copline);
6672 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6673 CvCONST(cv) ? "Constant subroutine %s redefined"
6674 : "Subroutine %s redefined"
6676 CopLINE_set(PL_curcop, oldline);
6686 if (cv) /* must reuse cv if autoloaded */
6689 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6693 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6699 (void)gv_fetchfile(filename);
6700 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6701 an external constant string */
6703 CvXSUB(cv) = subaddr;
6706 process_special_blocks(name, gv, cv);
6716 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6721 OP* pegop = newOP(OP_NULL, 0);
6725 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6726 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6729 if ((cv = GvFORM(gv))) {
6730 if (ckWARN(WARN_REDEFINE)) {
6731 const line_t oldline = CopLINE(PL_curcop);
6732 if (PL_parser && PL_parser->copline != NOLINE)
6733 CopLINE_set(PL_curcop, PL_parser->copline);
6735 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6736 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6738 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6739 "Format STDOUT redefined");
6741 CopLINE_set(PL_curcop, oldline);
6748 CvFILE_set_from_cop(cv, PL_curcop);
6751 pad_tidy(padtidy_FORMAT);
6752 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6753 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6754 OpREFCNT_set(CvROOT(cv), 1);
6755 CvSTART(cv) = LINKLIST(CvROOT(cv));
6756 CvROOT(cv)->op_next = 0;
6757 CALL_PEEP(CvSTART(cv));
6759 op_getmad(o,pegop,'n');
6760 op_getmad_weak(block, pegop, 'b');
6765 PL_parser->copline = NOLINE;
6773 Perl_newANONLIST(pTHX_ OP *o)
6775 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6779 Perl_newANONHASH(pTHX_ OP *o)
6781 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6785 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6787 return newANONATTRSUB(floor, proto, NULL, block);
6791 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6793 return newUNOP(OP_REFGEN, 0,
6794 newSVOP(OP_ANONCODE, 0,
6795 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6799 Perl_oopsAV(pTHX_ OP *o)
6803 PERL_ARGS_ASSERT_OOPSAV;
6805 switch (o->op_type) {
6807 o->op_type = OP_PADAV;
6808 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6809 return ref(o, OP_RV2AV);
6812 o->op_type = OP_RV2AV;
6813 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6818 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6825 Perl_oopsHV(pTHX_ OP *o)
6829 PERL_ARGS_ASSERT_OOPSHV;
6831 switch (o->op_type) {
6834 o->op_type = OP_PADHV;
6835 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6836 return ref(o, OP_RV2HV);
6840 o->op_type = OP_RV2HV;
6841 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6846 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6853 Perl_newAVREF(pTHX_ OP *o)
6857 PERL_ARGS_ASSERT_NEWAVREF;
6859 if (o->op_type == OP_PADANY) {
6860 o->op_type = OP_PADAV;
6861 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6864 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6865 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6866 "Using an array as a reference is deprecated");
6868 return newUNOP(OP_RV2AV, 0, scalar(o));
6872 Perl_newGVREF(pTHX_ I32 type, OP *o)
6874 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6875 return newUNOP(OP_NULL, 0, o);
6876 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6880 Perl_newHVREF(pTHX_ OP *o)
6884 PERL_ARGS_ASSERT_NEWHVREF;
6886 if (o->op_type == OP_PADANY) {
6887 o->op_type = OP_PADHV;
6888 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6891 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6892 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6893 "Using a hash as a reference is deprecated");
6895 return newUNOP(OP_RV2HV, 0, scalar(o));
6899 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6901 return newUNOP(OP_RV2CV, flags, scalar(o));
6905 Perl_newSVREF(pTHX_ OP *o)
6909 PERL_ARGS_ASSERT_NEWSVREF;
6911 if (o->op_type == OP_PADANY) {
6912 o->op_type = OP_PADSV;
6913 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6916 return newUNOP(OP_RV2SV, 0, scalar(o));
6919 /* Check routines. See the comments at the top of this file for details
6920 * on when these are called */
6923 Perl_ck_anoncode(pTHX_ OP *o)
6925 PERL_ARGS_ASSERT_CK_ANONCODE;
6927 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
6929 cSVOPo->op_sv = NULL;
6934 Perl_ck_bitop(pTHX_ OP *o)
6938 PERL_ARGS_ASSERT_CK_BITOP;
6940 #define OP_IS_NUMCOMPARE(op) \
6941 ((op) == OP_LT || (op) == OP_I_LT || \
6942 (op) == OP_GT || (op) == OP_I_GT || \
6943 (op) == OP_LE || (op) == OP_I_LE || \
6944 (op) == OP_GE || (op) == OP_I_GE || \
6945 (op) == OP_EQ || (op) == OP_I_EQ || \
6946 (op) == OP_NE || (op) == OP_I_NE || \
6947 (op) == OP_NCMP || (op) == OP_I_NCMP)
6948 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6949 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6950 && (o->op_type == OP_BIT_OR
6951 || o->op_type == OP_BIT_AND
6952 || o->op_type == OP_BIT_XOR))
6954 const OP * const left = cBINOPo->op_first;
6955 const OP * const right = left->op_sibling;
6956 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6957 (left->op_flags & OPf_PARENS) == 0) ||
6958 (OP_IS_NUMCOMPARE(right->op_type) &&
6959 (right->op_flags & OPf_PARENS) == 0))
6960 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6961 "Possible precedence problem on bitwise %c operator",
6962 o->op_type == OP_BIT_OR ? '|'
6963 : o->op_type == OP_BIT_AND ? '&' : '^'
6970 Perl_ck_concat(pTHX_ OP *o)
6972 const OP * const kid = cUNOPo->op_first;
6974 PERL_ARGS_ASSERT_CK_CONCAT;
6975 PERL_UNUSED_CONTEXT;
6977 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6978 !(kUNOP->op_first->op_flags & OPf_MOD))
6979 o->op_flags |= OPf_STACKED;
6984 Perl_ck_spair(pTHX_ OP *o)
6988 PERL_ARGS_ASSERT_CK_SPAIR;
6990 if (o->op_flags & OPf_KIDS) {
6993 const OPCODE type = o->op_type;
6994 o = modkids(ck_fun(o), type);
6995 kid = cUNOPo->op_first;
6996 newop = kUNOP->op_first->op_sibling;
6998 const OPCODE type = newop->op_type;
6999 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7000 type == OP_PADAV || type == OP_PADHV ||
7001 type == OP_RV2AV || type == OP_RV2HV)
7005 op_getmad(kUNOP->op_first,newop,'K');
7007 op_free(kUNOP->op_first);
7009 kUNOP->op_first = newop;
7011 o->op_ppaddr = PL_ppaddr[++o->op_type];
7016 Perl_ck_delete(pTHX_ OP *o)
7018 PERL_ARGS_ASSERT_CK_DELETE;
7022 if (o->op_flags & OPf_KIDS) {
7023 OP * const kid = cUNOPo->op_first;
7024 switch (kid->op_type) {
7026 o->op_flags |= OPf_SPECIAL;
7029 o->op_private |= OPpSLICE;
7032 o->op_flags |= OPf_SPECIAL;
7037 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7040 if (kid->op_private & OPpLVAL_INTRO)
7041 o->op_private |= OPpLVAL_INTRO;
7048 Perl_ck_die(pTHX_ OP *o)
7050 PERL_ARGS_ASSERT_CK_DIE;
7053 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7059 Perl_ck_eof(pTHX_ OP *o)
7063 PERL_ARGS_ASSERT_CK_EOF;
7065 if (o->op_flags & OPf_KIDS) {
7066 if (cLISTOPo->op_first->op_type == OP_STUB) {
7068 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7070 op_getmad(o,newop,'O');
7082 Perl_ck_eval(pTHX_ OP *o)
7086 PERL_ARGS_ASSERT_CK_EVAL;
7088 PL_hints |= HINT_BLOCK_SCOPE;
7089 if (o->op_flags & OPf_KIDS) {
7090 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7093 o->op_flags &= ~OPf_KIDS;
7096 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7102 cUNOPo->op_first = 0;
7107 NewOp(1101, enter, 1, LOGOP);
7108 enter->op_type = OP_ENTERTRY;
7109 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7110 enter->op_private = 0;
7112 /* establish postfix order */
7113 enter->op_next = (OP*)enter;
7115 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7116 o->op_type = OP_LEAVETRY;
7117 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7118 enter->op_other = o;
7119 op_getmad(oldo,o,'O');
7133 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7134 op_getmad(oldo,o,'O');
7136 o->op_targ = (PADOFFSET)PL_hints;
7137 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7138 /* Store a copy of %^H that pp_entereval can pick up. */
7139 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7140 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7141 cUNOPo->op_first->op_sibling = hhop;
7142 o->op_private |= OPpEVAL_HAS_HH;
7148 Perl_ck_exit(pTHX_ OP *o)
7150 PERL_ARGS_ASSERT_CK_EXIT;
7153 HV * const table = GvHV(PL_hintgv);
7155 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7156 if (svp && *svp && SvTRUE(*svp))
7157 o->op_private |= OPpEXIT_VMSISH;
7159 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7165 Perl_ck_exec(pTHX_ OP *o)
7167 PERL_ARGS_ASSERT_CK_EXEC;
7169 if (o->op_flags & OPf_STACKED) {
7172 kid = cUNOPo->op_first->op_sibling;
7173 if (kid->op_type == OP_RV2GV)
7182 Perl_ck_exists(pTHX_ OP *o)
7186 PERL_ARGS_ASSERT_CK_EXISTS;
7189 if (o->op_flags & OPf_KIDS) {
7190 OP * const kid = cUNOPo->op_first;
7191 if (kid->op_type == OP_ENTERSUB) {
7192 (void) ref(kid, o->op_type);
7193 if (kid->op_type != OP_RV2CV
7194 && !(PL_parser && PL_parser->error_count))
7195 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7197 o->op_private |= OPpEXISTS_SUB;
7199 else if (kid->op_type == OP_AELEM)
7200 o->op_flags |= OPf_SPECIAL;
7201 else if (kid->op_type != OP_HELEM)
7202 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7210 Perl_ck_rvconst(pTHX_ register OP *o)
7213 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7215 PERL_ARGS_ASSERT_CK_RVCONST;
7217 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7218 if (o->op_type == OP_RV2CV)
7219 o->op_private &= ~1;
7221 if (kid->op_type == OP_CONST) {
7224 SV * const kidsv = kid->op_sv;
7226 /* Is it a constant from cv_const_sv()? */
7227 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7228 SV * const rsv = SvRV(kidsv);
7229 const svtype type = SvTYPE(rsv);
7230 const char *badtype = NULL;
7232 switch (o->op_type) {
7234 if (type > SVt_PVMG)
7235 badtype = "a SCALAR";
7238 if (type != SVt_PVAV)
7239 badtype = "an ARRAY";
7242 if (type != SVt_PVHV)
7246 if (type != SVt_PVCV)
7251 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7254 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7255 const char *badthing;
7256 switch (o->op_type) {
7258 badthing = "a SCALAR";
7261 badthing = "an ARRAY";
7264 badthing = "a HASH";
7272 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7273 SVfARG(kidsv), badthing);
7276 * This is a little tricky. We only want to add the symbol if we
7277 * didn't add it in the lexer. Otherwise we get duplicate strict
7278 * warnings. But if we didn't add it in the lexer, we must at
7279 * least pretend like we wanted to add it even if it existed before,
7280 * or we get possible typo warnings. OPpCONST_ENTERED says
7281 * whether the lexer already added THIS instance of this symbol.
7283 iscv = (o->op_type == OP_RV2CV) * 2;
7285 gv = gv_fetchsv(kidsv,
7286 iscv | !(kid->op_private & OPpCONST_ENTERED),
7289 : o->op_type == OP_RV2SV
7291 : o->op_type == OP_RV2AV
7293 : o->op_type == OP_RV2HV
7296 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7298 kid->op_type = OP_GV;
7299 SvREFCNT_dec(kid->op_sv);
7301 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7302 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7303 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7305 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7307 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7309 kid->op_private = 0;
7310 kid->op_ppaddr = PL_ppaddr[OP_GV];
7311 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7319 Perl_ck_ftst(pTHX_ OP *o)
7322 const I32 type = o->op_type;
7324 PERL_ARGS_ASSERT_CK_FTST;
7326 if (o->op_flags & OPf_REF) {
7329 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7330 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7331 const OPCODE kidtype = kid->op_type;
7333 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7334 OP * const newop = newGVOP(type, OPf_REF,
7335 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7337 op_getmad(o,newop,'O');
7343 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7344 o->op_private |= OPpFT_ACCESS;
7345 if (PL_check[kidtype] == Perl_ck_ftst
7346 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7347 o->op_private |= OPpFT_STACKED;
7348 kid->op_private |= OPpFT_STACKING;
7357 if (type == OP_FTTTY)
7358 o = newGVOP(type, OPf_REF, PL_stdingv);
7360 o = newUNOP(type, 0, newDEFSVOP());
7361 op_getmad(oldo,o,'O');
7367 Perl_ck_fun(pTHX_ OP *o)
7370 const int type = o->op_type;
7371 register I32 oa = PL_opargs[type] >> OASHIFT;
7373 PERL_ARGS_ASSERT_CK_FUN;
7375 if (o->op_flags & OPf_STACKED) {
7376 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7379 return no_fh_allowed(o);
7382 if (o->op_flags & OPf_KIDS) {
7383 OP **tokid = &cLISTOPo->op_first;
7384 register OP *kid = cLISTOPo->op_first;
7388 if (kid->op_type == OP_PUSHMARK ||
7389 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7391 tokid = &kid->op_sibling;
7392 kid = kid->op_sibling;
7394 if (!kid && PL_opargs[type] & OA_DEFGV)
7395 *tokid = kid = newDEFSVOP();
7399 sibl = kid->op_sibling;
7401 if (!sibl && kid->op_type == OP_STUB) {
7408 /* list seen where single (scalar) arg expected? */
7409 if (numargs == 1 && !(oa >> 4)
7410 && kid->op_type == OP_LIST && type != OP_SCALAR)
7412 return too_many_arguments(o,PL_op_desc[type]);
7425 if ((type == OP_PUSH || type == OP_UNSHIFT)
7426 && !kid->op_sibling)
7427 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7428 "Useless use of %s with no values",
7431 if (kid->op_type == OP_CONST &&
7432 (kid->op_private & OPpCONST_BARE))
7434 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7435 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7436 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7437 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7438 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7440 op_getmad(kid,newop,'K');
7445 kid->op_sibling = sibl;
7448 else if (kid->op_type == OP_CONST
7449 && ( !SvROK(cSVOPx_sv(kid))
7450 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7452 bad_type(numargs, "array", PL_op_desc[type], kid);
7453 /* Defer checks to run-time if we have a scalar arg */
7454 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7455 op_lvalue(kid, type);
7459 if (kid->op_type == OP_CONST &&
7460 (kid->op_private & OPpCONST_BARE))
7462 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7463 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7464 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7465 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7466 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7468 op_getmad(kid,newop,'K');
7473 kid->op_sibling = sibl;
7476 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7477 bad_type(numargs, "hash", PL_op_desc[type], kid);
7478 op_lvalue(kid, type);
7482 OP * const newop = newUNOP(OP_NULL, 0, kid);
7483 kid->op_sibling = 0;
7485 newop->op_next = newop;
7487 kid->op_sibling = sibl;
7492 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7493 if (kid->op_type == OP_CONST &&
7494 (kid->op_private & OPpCONST_BARE))
7496 OP * const newop = newGVOP(OP_GV, 0,
7497 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7498 if (!(o->op_private & 1) && /* if not unop */
7499 kid == cLISTOPo->op_last)
7500 cLISTOPo->op_last = newop;
7502 op_getmad(kid,newop,'K');
7508 else if (kid->op_type == OP_READLINE) {
7509 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7510 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7513 I32 flags = OPf_SPECIAL;
7517 /* is this op a FH constructor? */
7518 if (is_handle_constructor(o,numargs)) {
7519 const char *name = NULL;
7523 /* Set a flag to tell rv2gv to vivify
7524 * need to "prove" flag does not mean something
7525 * else already - NI-S 1999/05/07
7528 if (kid->op_type == OP_PADSV) {
7530 = PAD_COMPNAME_SV(kid->op_targ);
7531 name = SvPV_const(namesv, len);
7533 else if (kid->op_type == OP_RV2SV
7534 && kUNOP->op_first->op_type == OP_GV)
7536 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7538 len = GvNAMELEN(gv);
7540 else if (kid->op_type == OP_AELEM
7541 || kid->op_type == OP_HELEM)
7544 OP *op = ((BINOP*)kid)->op_first;
7548 const char * const a =
7549 kid->op_type == OP_AELEM ?
7551 if (((op->op_type == OP_RV2AV) ||
7552 (op->op_type == OP_RV2HV)) &&
7553 (firstop = ((UNOP*)op)->op_first) &&
7554 (firstop->op_type == OP_GV)) {
7555 /* packagevar $a[] or $h{} */
7556 GV * const gv = cGVOPx_gv(firstop);
7564 else if (op->op_type == OP_PADAV
7565 || op->op_type == OP_PADHV) {
7566 /* lexicalvar $a[] or $h{} */
7567 const char * const padname =
7568 PAD_COMPNAME_PV(op->op_targ);
7577 name = SvPV_const(tmpstr, len);
7582 name = "__ANONIO__";
7585 op_lvalue(kid, type);
7589 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7590 namesv = PAD_SVl(targ);
7591 SvUPGRADE(namesv, SVt_PV);
7593 sv_setpvs(namesv, "$");
7594 sv_catpvn(namesv, name, len);
7597 kid->op_sibling = 0;
7598 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7599 kid->op_targ = targ;
7600 kid->op_private |= priv;
7602 kid->op_sibling = sibl;
7608 op_lvalue(scalar(kid), type);
7612 tokid = &kid->op_sibling;
7613 kid = kid->op_sibling;
7616 if (kid && kid->op_type != OP_STUB)
7617 return too_many_arguments(o,OP_DESC(o));
7618 o->op_private |= numargs;
7620 /* FIXME - should the numargs move as for the PERL_MAD case? */
7621 o->op_private |= numargs;
7623 return too_many_arguments(o,OP_DESC(o));
7627 else if (PL_opargs[type] & OA_DEFGV) {
7629 OP *newop = newUNOP(type, 0, newDEFSVOP());
7630 op_getmad(o,newop,'O');
7633 /* Ordering of these two is important to keep f_map.t passing. */
7635 return newUNOP(type, 0, newDEFSVOP());
7640 while (oa & OA_OPTIONAL)
7642 if (oa && oa != OA_LIST)
7643 return too_few_arguments(o,OP_DESC(o));
7649 Perl_ck_glob(pTHX_ OP *o)
7654 PERL_ARGS_ASSERT_CK_GLOB;
7657 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7658 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
7660 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7661 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7663 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7666 #if !defined(PERL_EXTERNAL_GLOB)
7667 /* XXX this can be tightened up and made more failsafe. */
7668 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7671 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7672 newSVpvs("File::Glob"), NULL, NULL, NULL);
7673 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7674 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7675 GvCV_set(gv, GvCV(glob_gv));
7676 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7677 GvIMPORTED_CV_on(gv);
7681 #endif /* PERL_EXTERNAL_GLOB */
7683 assert(!(o->op_flags & OPf_SPECIAL));
7684 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7687 * \ null - const(wildcard)
7692 * \ mark - glob - rv2cv
7693 * | \ gv(CORE::GLOBAL::glob)
7695 * \ null - const(wildcard) - const(ix)
7697 o->op_flags |= OPf_SPECIAL;
7698 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
7699 op_append_elem(OP_GLOB, o,
7700 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7701 o = newLISTOP(OP_LIST, 0, o, NULL);
7702 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7703 op_append_elem(OP_LIST, o,
7704 scalar(newUNOP(OP_RV2CV, 0,
7705 newGVOP(OP_GV, 0, gv)))));
7706 o = newUNOP(OP_NULL, 0, ck_subr(o));
7707 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
7710 gv = newGVgen("main");
7712 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7718 Perl_ck_grep(pTHX_ OP *o)
7723 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7726 PERL_ARGS_ASSERT_CK_GREP;
7728 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7729 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7731 if (o->op_flags & OPf_STACKED) {
7734 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7735 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7736 return no_fh_allowed(o);
7737 for (k = kid; k; k = k->op_next) {
7740 NewOp(1101, gwop, 1, LOGOP);
7741 kid->op_next = (OP*)gwop;
7742 o->op_flags &= ~OPf_STACKED;
7744 kid = cLISTOPo->op_first->op_sibling;
7745 if (type == OP_MAPWHILE)
7750 if (PL_parser && PL_parser->error_count)
7752 kid = cLISTOPo->op_first->op_sibling;
7753 if (kid->op_type != OP_NULL)
7754 Perl_croak(aTHX_ "panic: ck_grep");
7755 kid = kUNOP->op_first;
7758 NewOp(1101, gwop, 1, LOGOP);
7759 gwop->op_type = type;
7760 gwop->op_ppaddr = PL_ppaddr[type];
7761 gwop->op_first = listkids(o);
7762 gwop->op_flags |= OPf_KIDS;
7763 gwop->op_other = LINKLIST(kid);
7764 kid->op_next = (OP*)gwop;
7765 offset = pad_findmy_pvs("$_", 0);
7766 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7767 o->op_private = gwop->op_private = 0;
7768 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7771 o->op_private = gwop->op_private = OPpGREP_LEX;
7772 gwop->op_targ = o->op_targ = offset;
7775 kid = cLISTOPo->op_first->op_sibling;
7776 if (!kid || !kid->op_sibling)
7777 return too_few_arguments(o,OP_DESC(o));
7778 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7779 op_lvalue(kid, OP_GREPSTART);
7785 Perl_ck_index(pTHX_ OP *o)
7787 PERL_ARGS_ASSERT_CK_INDEX;
7789 if (o->op_flags & OPf_KIDS) {
7790 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7792 kid = kid->op_sibling; /* get past "big" */
7793 if (kid && kid->op_type == OP_CONST) {
7794 const bool save_taint = PL_tainted;
7795 fbm_compile(((SVOP*)kid)->op_sv, 0);
7796 PL_tainted = save_taint;
7803 Perl_ck_lfun(pTHX_ OP *o)
7805 const OPCODE type = o->op_type;
7807 PERL_ARGS_ASSERT_CK_LFUN;
7809 return modkids(ck_fun(o), type);
7813 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7815 PERL_ARGS_ASSERT_CK_DEFINED;
7817 if ((o->op_flags & OPf_KIDS)) {
7818 switch (cUNOPo->op_first->op_type) {
7820 /* This is needed for
7821 if (defined %stash::)
7822 to work. Do not break Tk.
7824 break; /* Globals via GV can be undef */
7826 case OP_AASSIGN: /* Is this a good idea? */
7827 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7828 "defined(@array) is deprecated");
7829 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7830 "\t(Maybe you should just omit the defined()?)\n");
7834 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7835 "defined(%%hash) is deprecated");
7836 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7837 "\t(Maybe you should just omit the defined()?)\n");
7848 Perl_ck_readline(pTHX_ OP *o)
7850 PERL_ARGS_ASSERT_CK_READLINE;
7852 if (!(o->op_flags & OPf_KIDS)) {
7854 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7856 op_getmad(o,newop,'O');
7866 Perl_ck_rfun(pTHX_ OP *o)
7868 const OPCODE type = o->op_type;
7870 PERL_ARGS_ASSERT_CK_RFUN;
7872 return refkids(ck_fun(o), type);
7876 Perl_ck_listiob(pTHX_ OP *o)
7880 PERL_ARGS_ASSERT_CK_LISTIOB;
7882 kid = cLISTOPo->op_first;
7885 kid = cLISTOPo->op_first;
7887 if (kid->op_type == OP_PUSHMARK)
7888 kid = kid->op_sibling;
7889 if (kid && o->op_flags & OPf_STACKED)
7890 kid = kid->op_sibling;
7891 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7892 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7893 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7894 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7895 cLISTOPo->op_first->op_sibling = kid;
7896 cLISTOPo->op_last = kid;
7897 kid = kid->op_sibling;
7902 op_append_elem(o->op_type, o, newDEFSVOP());
7908 Perl_ck_smartmatch(pTHX_ OP *o)
7911 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7912 if (0 == (o->op_flags & OPf_SPECIAL)) {
7913 OP *first = cBINOPo->op_first;
7914 OP *second = first->op_sibling;
7916 /* Implicitly take a reference to an array or hash */
7917 first->op_sibling = NULL;
7918 first = cBINOPo->op_first = ref_array_or_hash(first);
7919 second = first->op_sibling = ref_array_or_hash(second);
7921 /* Implicitly take a reference to a regular expression */
7922 if (first->op_type == OP_MATCH) {
7923 first->op_type = OP_QR;
7924 first->op_ppaddr = PL_ppaddr[OP_QR];
7926 if (second->op_type == OP_MATCH) {
7927 second->op_type = OP_QR;
7928 second->op_ppaddr = PL_ppaddr[OP_QR];
7937 Perl_ck_sassign(pTHX_ OP *o)
7940 OP * const kid = cLISTOPo->op_first;
7942 PERL_ARGS_ASSERT_CK_SASSIGN;
7944 /* has a disposable target? */
7945 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7946 && !(kid->op_flags & OPf_STACKED)
7947 /* Cannot steal the second time! */
7948 && !(kid->op_private & OPpTARGET_MY)
7949 /* Keep the full thing for madskills */
7953 OP * const kkid = kid->op_sibling;
7955 /* Can just relocate the target. */
7956 if (kkid && kkid->op_type == OP_PADSV
7957 && !(kkid->op_private & OPpLVAL_INTRO))
7959 kid->op_targ = kkid->op_targ;
7961 /* Now we do not need PADSV and SASSIGN. */
7962 kid->op_sibling = o->op_sibling; /* NULL */
7963 cLISTOPo->op_first = NULL;
7966 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7970 if (kid->op_sibling) {
7971 OP *kkid = kid->op_sibling;
7972 /* For state variable assignment, kkid is a list op whose op_last
7974 if ((kkid->op_type == OP_PADSV ||
7975 (kkid->op_type == OP_LIST &&
7976 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
7979 && (kkid->op_private & OPpLVAL_INTRO)
7980 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7981 const PADOFFSET target = kkid->op_targ;
7982 OP *const other = newOP(OP_PADSV,
7984 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7985 OP *const first = newOP(OP_NULL, 0);
7986 OP *const nullop = newCONDOP(0, first, o, other);
7987 OP *const condop = first->op_next;
7988 /* hijacking PADSTALE for uninitialized state variables */
7989 SvPADSTALE_on(PAD_SVl(target));
7991 condop->op_type = OP_ONCE;
7992 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7993 condop->op_targ = target;
7994 other->op_targ = target;
7996 /* Because we change the type of the op here, we will skip the
7997 assignment binop->op_last = binop->op_first->op_sibling; at the
7998 end of Perl_newBINOP(). So need to do it here. */
7999 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8008 Perl_ck_match(pTHX_ OP *o)
8012 PERL_ARGS_ASSERT_CK_MATCH;
8014 if (o->op_type != OP_QR && PL_compcv) {
8015 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8016 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8017 o->op_targ = offset;
8018 o->op_private |= OPpTARGET_MY;
8021 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8022 o->op_private |= OPpRUNTIME;
8027 Perl_ck_method(pTHX_ OP *o)
8029 OP * const kid = cUNOPo->op_first;
8031 PERL_ARGS_ASSERT_CK_METHOD;
8033 if (kid->op_type == OP_CONST) {
8034 SV* sv = kSVOP->op_sv;
8035 const char * const method = SvPVX_const(sv);
8036 if (!(strchr(method, ':') || strchr(method, '\''))) {
8038 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8039 sv = newSVpvn_share(method, SvCUR(sv), 0);
8042 kSVOP->op_sv = NULL;
8044 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8046 op_getmad(o,cmop,'O');
8057 Perl_ck_null(pTHX_ OP *o)
8059 PERL_ARGS_ASSERT_CK_NULL;
8060 PERL_UNUSED_CONTEXT;
8065 Perl_ck_open(pTHX_ OP *o)
8068 HV * const table = GvHV(PL_hintgv);
8070 PERL_ARGS_ASSERT_CK_OPEN;
8073 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8076 const char *d = SvPV_const(*svp, len);
8077 const I32 mode = mode_from_discipline(d, len);
8078 if (mode & O_BINARY)
8079 o->op_private |= OPpOPEN_IN_RAW;
8080 else if (mode & O_TEXT)
8081 o->op_private |= OPpOPEN_IN_CRLF;
8084 svp = hv_fetchs(table, "open_OUT", FALSE);
8087 const char *d = SvPV_const(*svp, len);
8088 const I32 mode = mode_from_discipline(d, len);
8089 if (mode & O_BINARY)
8090 o->op_private |= OPpOPEN_OUT_RAW;
8091 else if (mode & O_TEXT)
8092 o->op_private |= OPpOPEN_OUT_CRLF;
8095 if (o->op_type == OP_BACKTICK) {
8096 if (!(o->op_flags & OPf_KIDS)) {
8097 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8099 op_getmad(o,newop,'O');
8108 /* In case of three-arg dup open remove strictness
8109 * from the last arg if it is a bareword. */
8110 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8111 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8115 if ((last->op_type == OP_CONST) && /* The bareword. */
8116 (last->op_private & OPpCONST_BARE) &&
8117 (last->op_private & OPpCONST_STRICT) &&
8118 (oa = first->op_sibling) && /* The fh. */
8119 (oa = oa->op_sibling) && /* The mode. */
8120 (oa->op_type == OP_CONST) &&
8121 SvPOK(((SVOP*)oa)->op_sv) &&
8122 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8123 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8124 (last == oa->op_sibling)) /* The bareword. */
8125 last->op_private &= ~OPpCONST_STRICT;
8131 Perl_ck_repeat(pTHX_ OP *o)
8133 PERL_ARGS_ASSERT_CK_REPEAT;
8135 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8136 o->op_private |= OPpREPEAT_DOLIST;
8137 cBINOPo->op_first = force_list(cBINOPo->op_first);
8145 Perl_ck_require(pTHX_ OP *o)
8150 PERL_ARGS_ASSERT_CK_REQUIRE;
8152 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8153 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8155 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8156 SV * const sv = kid->op_sv;
8157 U32 was_readonly = SvREADONLY(sv);
8164 sv_force_normal_flags(sv, 0);
8165 assert(!SvREADONLY(sv));
8175 for (; s < end; s++) {
8176 if (*s == ':' && s[1] == ':') {
8178 Move(s+2, s+1, end - s - 1, char);
8183 sv_catpvs(sv, ".pm");
8184 SvFLAGS(sv) |= was_readonly;
8188 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8189 /* handle override, if any */
8190 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8191 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8192 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8193 gv = gvp ? *gvp : NULL;
8197 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8198 OP * const kid = cUNOPo->op_first;
8201 cUNOPo->op_first = 0;
8205 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8206 op_append_elem(OP_LIST, kid,
8207 scalar(newUNOP(OP_RV2CV, 0,
8210 op_getmad(o,newop,'O');
8214 return scalar(ck_fun(o));
8218 Perl_ck_return(pTHX_ OP *o)
8223 PERL_ARGS_ASSERT_CK_RETURN;
8225 kid = cLISTOPo->op_first->op_sibling;
8226 if (CvLVALUE(PL_compcv)) {
8227 for (; kid; kid = kid->op_sibling)
8228 op_lvalue(kid, OP_LEAVESUBLV);
8235 Perl_ck_select(pTHX_ OP *o)
8240 PERL_ARGS_ASSERT_CK_SELECT;
8242 if (o->op_flags & OPf_KIDS) {
8243 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8244 if (kid && kid->op_sibling) {
8245 o->op_type = OP_SSELECT;
8246 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8248 return fold_constants(o);
8252 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8253 if (kid && kid->op_type == OP_RV2GV)
8254 kid->op_private &= ~HINT_STRICT_REFS;
8259 Perl_ck_shift(pTHX_ OP *o)
8262 const I32 type = o->op_type;
8264 PERL_ARGS_ASSERT_CK_SHIFT;
8266 if (!(o->op_flags & OPf_KIDS)) {
8269 if (!CvUNIQUE(PL_compcv)) {
8270 o->op_flags |= OPf_SPECIAL;
8274 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8277 OP * const oldo = o;
8278 o = newUNOP(type, 0, scalar(argop));
8279 op_getmad(oldo,o,'O');
8284 return newUNOP(type, 0, scalar(argop));
8287 return scalar(ck_fun(o));
8291 Perl_ck_sort(pTHX_ OP *o)
8296 PERL_ARGS_ASSERT_CK_SORT;
8298 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8299 HV * const hinthv = GvHV(PL_hintgv);
8301 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8303 const I32 sorthints = (I32)SvIV(*svp);
8304 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8305 o->op_private |= OPpSORT_QSORT;
8306 if ((sorthints & HINT_SORT_STABLE) != 0)
8307 o->op_private |= OPpSORT_STABLE;
8312 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8314 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8315 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8317 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8319 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8321 if (kid->op_type == OP_SCOPE) {
8325 else if (kid->op_type == OP_LEAVE) {
8326 if (o->op_type == OP_SORT) {
8327 op_null(kid); /* wipe out leave */
8330 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8331 if (k->op_next == kid)
8333 /* don't descend into loops */
8334 else if (k->op_type == OP_ENTERLOOP
8335 || k->op_type == OP_ENTERITER)
8337 k = cLOOPx(k)->op_lastop;
8342 kid->op_next = 0; /* just disconnect the leave */
8343 k = kLISTOP->op_first;
8348 if (o->op_type == OP_SORT) {
8349 /* provide scalar context for comparison function/block */
8355 o->op_flags |= OPf_SPECIAL;
8357 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8360 firstkid = firstkid->op_sibling;
8363 /* provide list context for arguments */
8364 if (o->op_type == OP_SORT)
8371 S_simplify_sort(pTHX_ OP *o)
8374 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8380 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8382 if (!(o->op_flags & OPf_STACKED))
8384 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8385 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8386 kid = kUNOP->op_first; /* get past null */
8387 if (kid->op_type != OP_SCOPE)
8389 kid = kLISTOP->op_last; /* get past scope */
8390 switch(kid->op_type) {
8398 k = kid; /* remember this node*/
8399 if (kBINOP->op_first->op_type != OP_RV2SV)
8401 kid = kBINOP->op_first; /* get past cmp */
8402 if (kUNOP->op_first->op_type != OP_GV)
8404 kid = kUNOP->op_first; /* get past rv2sv */
8406 if (GvSTASH(gv) != PL_curstash)
8408 gvname = GvNAME(gv);
8409 if (*gvname == 'a' && gvname[1] == '\0')
8411 else if (*gvname == 'b' && gvname[1] == '\0')
8416 kid = k; /* back to cmp */
8417 if (kBINOP->op_last->op_type != OP_RV2SV)
8419 kid = kBINOP->op_last; /* down to 2nd arg */
8420 if (kUNOP->op_first->op_type != OP_GV)
8422 kid = kUNOP->op_first; /* get past rv2sv */
8424 if (GvSTASH(gv) != PL_curstash)
8426 gvname = GvNAME(gv);
8428 ? !(*gvname == 'a' && gvname[1] == '\0')
8429 : !(*gvname == 'b' && gvname[1] == '\0'))
8431 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8433 o->op_private |= OPpSORT_DESCEND;
8434 if (k->op_type == OP_NCMP)
8435 o->op_private |= OPpSORT_NUMERIC;
8436 if (k->op_type == OP_I_NCMP)
8437 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8438 kid = cLISTOPo->op_first->op_sibling;
8439 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8441 op_getmad(kid,o,'S'); /* then delete it */
8443 op_free(kid); /* then delete it */
8448 Perl_ck_split(pTHX_ OP *o)
8453 PERL_ARGS_ASSERT_CK_SPLIT;
8455 if (o->op_flags & OPf_STACKED)
8456 return no_fh_allowed(o);
8458 kid = cLISTOPo->op_first;
8459 if (kid->op_type != OP_NULL)
8460 Perl_croak(aTHX_ "panic: ck_split");
8461 kid = kid->op_sibling;
8462 op_free(cLISTOPo->op_first);
8464 cLISTOPo->op_first = kid;
8466 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8467 cLISTOPo->op_last = kid; /* There was only one element previously */
8470 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8471 OP * const sibl = kid->op_sibling;
8472 kid->op_sibling = 0;
8473 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8474 if (cLISTOPo->op_first == cLISTOPo->op_last)
8475 cLISTOPo->op_last = kid;
8476 cLISTOPo->op_first = kid;
8477 kid->op_sibling = sibl;
8480 kid->op_type = OP_PUSHRE;
8481 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8483 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8484 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8485 "Use of /g modifier is meaningless in split");
8488 if (!kid->op_sibling)
8489 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8491 kid = kid->op_sibling;
8494 if (!kid->op_sibling)
8495 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8496 assert(kid->op_sibling);
8498 kid = kid->op_sibling;
8501 if (kid->op_sibling)
8502 return too_many_arguments(o,OP_DESC(o));
8508 Perl_ck_join(pTHX_ OP *o)
8510 const OP * const kid = cLISTOPo->op_first->op_sibling;
8512 PERL_ARGS_ASSERT_CK_JOIN;
8514 if (kid && kid->op_type == OP_MATCH) {
8515 if (ckWARN(WARN_SYNTAX)) {
8516 const REGEXP *re = PM_GETRE(kPMOP);
8517 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8518 const STRLEN len = re ? RX_PRELEN(re) : 6;
8519 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8520 "/%.*s/ should probably be written as \"%.*s\"",
8521 (int)len, pmstr, (int)len, pmstr);
8528 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8530 Examines an op, which is expected to identify a subroutine at runtime,
8531 and attempts to determine at compile time which subroutine it identifies.
8532 This is normally used during Perl compilation to determine whether
8533 a prototype can be applied to a function call. I<cvop> is the op
8534 being considered, normally an C<rv2cv> op. A pointer to the identified
8535 subroutine is returned, if it could be determined statically, and a null
8536 pointer is returned if it was not possible to determine statically.
8538 Currently, the subroutine can be identified statically if the RV that the
8539 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8540 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8541 suitable if the constant value must be an RV pointing to a CV. Details of
8542 this process may change in future versions of Perl. If the C<rv2cv> op
8543 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8544 the subroutine statically: this flag is used to suppress compile-time
8545 magic on a subroutine call, forcing it to use default runtime behaviour.
8547 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8548 of a GV reference is modified. If a GV was examined and its CV slot was
8549 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8550 If the op is not optimised away, and the CV slot is later populated with
8551 a subroutine having a prototype, that flag eventually triggers the warning
8552 "called too early to check prototype".
8554 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8555 of returning a pointer to the subroutine it returns a pointer to the
8556 GV giving the most appropriate name for the subroutine in this context.
8557 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8558 (C<CvANON>) subroutine that is referenced through a GV it will be the
8559 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8560 A null pointer is returned as usual if there is no statically-determinable
8567 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8572 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8573 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8574 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8575 if (cvop->op_type != OP_RV2CV)
8577 if (cvop->op_private & OPpENTERSUB_AMPER)
8579 if (!(cvop->op_flags & OPf_KIDS))
8581 rvop = cUNOPx(cvop)->op_first;
8582 switch (rvop->op_type) {
8584 gv = cGVOPx_gv(rvop);
8587 if (flags & RV2CVOPCV_MARK_EARLY)
8588 rvop->op_private |= OPpEARLY_CV;
8593 SV *rv = cSVOPx_sv(rvop);
8603 if (SvTYPE((SV*)cv) != SVt_PVCV)
8605 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8606 if (!CvANON(cv) || !gv)
8615 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8617 Performs the default fixup of the arguments part of an C<entersub>
8618 op tree. This consists of applying list context to each of the
8619 argument ops. This is the standard treatment used on a call marked
8620 with C<&>, or a method call, or a call through a subroutine reference,
8621 or any other call where the callee can't be identified at compile time,
8622 or a call where the callee has no prototype.
8628 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8631 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8632 aop = cUNOPx(entersubop)->op_first;
8633 if (!aop->op_sibling)
8634 aop = cUNOPx(aop)->op_first;
8635 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8636 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8638 op_lvalue(aop, OP_ENTERSUB);
8645 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8647 Performs the fixup of the arguments part of an C<entersub> op tree
8648 based on a subroutine prototype. This makes various modifications to
8649 the argument ops, from applying context up to inserting C<refgen> ops,
8650 and checking the number and syntactic types of arguments, as directed by
8651 the prototype. This is the standard treatment used on a subroutine call,
8652 not marked with C<&>, where the callee can be identified at compile time
8653 and has a prototype.
8655 I<protosv> supplies the subroutine prototype to be applied to the call.
8656 It may be a normal defined scalar, of which the string value will be used.
8657 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8658 that has been cast to C<SV*>) which has a prototype. The prototype
8659 supplied, in whichever form, does not need to match the actual callee
8660 referenced by the op tree.
8662 If the argument ops disagree with the prototype, for example by having
8663 an unacceptable number of arguments, a valid op tree is returned anyway.
8664 The error is reflected in the parser state, normally resulting in a single
8665 exception at the top level of parsing which covers all the compilation
8666 errors that occurred. In the error message, the callee is referred to
8667 by the name defined by the I<namegv> parameter.
8673 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8676 const char *proto, *proto_end;
8677 OP *aop, *prev, *cvop;
8680 I32 contextclass = 0;
8681 const char *e = NULL;
8682 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8683 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8684 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8685 proto = SvPV(protosv, proto_len);
8686 proto_end = proto + proto_len;
8687 aop = cUNOPx(entersubop)->op_first;
8688 if (!aop->op_sibling)
8689 aop = cUNOPx(aop)->op_first;
8691 aop = aop->op_sibling;
8692 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8693 while (aop != cvop) {
8695 if (PL_madskills && aop->op_type == OP_STUB) {
8696 aop = aop->op_sibling;
8699 if (PL_madskills && aop->op_type == OP_NULL)
8700 o3 = ((UNOP*)aop)->op_first;
8704 if (proto >= proto_end)
8705 return too_many_arguments(entersubop, gv_ename(namegv));
8713 /* _ must be at the end */
8714 if (proto[1] && proto[1] != ';')
8729 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8731 arg == 1 ? "block or sub {}" : "sub {}",
8732 gv_ename(namegv), o3);
8735 /* '*' allows any scalar type, including bareword */
8738 if (o3->op_type == OP_RV2GV)
8739 goto wrapref; /* autoconvert GLOB -> GLOBref */
8740 else if (o3->op_type == OP_CONST)
8741 o3->op_private &= ~OPpCONST_STRICT;
8742 else if (o3->op_type == OP_ENTERSUB) {
8743 /* accidental subroutine, revert to bareword */
8744 OP *gvop = ((UNOP*)o3)->op_first;
8745 if (gvop && gvop->op_type == OP_NULL) {
8746 gvop = ((UNOP*)gvop)->op_first;
8748 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8751 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8752 (gvop = ((UNOP*)gvop)->op_first) &&
8753 gvop->op_type == OP_GV)
8755 GV * const gv = cGVOPx_gv(gvop);
8756 OP * const sibling = aop->op_sibling;
8757 SV * const n = newSVpvs("");
8759 OP * const oldaop = aop;
8763 gv_fullname4(n, gv, "", FALSE);
8764 aop = newSVOP(OP_CONST, 0, n);
8765 op_getmad(oldaop,aop,'O');
8766 prev->op_sibling = aop;
8767 aop->op_sibling = sibling;
8777 if (o3->op_type == OP_RV2AV ||
8778 o3->op_type == OP_PADAV ||
8779 o3->op_type == OP_RV2HV ||
8780 o3->op_type == OP_PADHV
8795 if (contextclass++ == 0) {
8796 e = strchr(proto, ']');
8797 if (!e || e == proto)
8806 const char *p = proto;
8807 const char *const end = proto;
8810 /* \[$] accepts any scalar lvalue */
8812 && Perl_op_lvalue_flags(aTHX_
8814 OP_READ, /* not entersub */
8817 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8819 gv_ename(namegv), o3);
8824 if (o3->op_type == OP_RV2GV)
8827 bad_type(arg, "symbol", gv_ename(namegv), o3);
8830 if (o3->op_type == OP_ENTERSUB)
8833 bad_type(arg, "subroutine entry", gv_ename(namegv),
8837 if (o3->op_type == OP_RV2SV ||
8838 o3->op_type == OP_PADSV ||
8839 o3->op_type == OP_HELEM ||
8840 o3->op_type == OP_AELEM)
8842 if (!contextclass) {
8843 /* \$ accepts any scalar lvalue */
8844 if (Perl_op_lvalue_flags(aTHX_
8846 OP_READ, /* not entersub */
8849 bad_type(arg, "scalar", gv_ename(namegv), o3);
8853 if (o3->op_type == OP_RV2AV ||
8854 o3->op_type == OP_PADAV)
8857 bad_type(arg, "array", gv_ename(namegv), o3);
8860 if (o3->op_type == OP_RV2HV ||
8861 o3->op_type == OP_PADHV)
8864 bad_type(arg, "hash", gv_ename(namegv), o3);
8868 OP* const kid = aop;
8869 OP* const sib = kid->op_sibling;
8870 kid->op_sibling = 0;
8871 aop = newUNOP(OP_REFGEN, 0, kid);
8872 aop->op_sibling = sib;
8873 prev->op_sibling = aop;
8875 if (contextclass && e) {
8890 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8891 gv_ename(namegv), SVfARG(protosv));
8894 op_lvalue(aop, OP_ENTERSUB);
8896 aop = aop->op_sibling;
8898 if (aop == cvop && *proto == '_') {
8899 /* generate an access to $_ */
8901 aop->op_sibling = prev->op_sibling;
8902 prev->op_sibling = aop; /* instead of cvop */
8904 if (!optional && proto_end > proto &&
8905 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8906 return too_few_arguments(entersubop, gv_ename(namegv));
8911 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8913 Performs the fixup of the arguments part of an C<entersub> op tree either
8914 based on a subroutine prototype or using default list-context processing.
8915 This is the standard treatment used on a subroutine call, not marked
8916 with C<&>, where the callee can be identified at compile time.
8918 I<protosv> supplies the subroutine prototype to be applied to the call,
8919 or indicates that there is no prototype. It may be a normal scalar,
8920 in which case if it is defined then the string value will be used
8921 as a prototype, and if it is undefined then there is no prototype.
8922 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8923 that has been cast to C<SV*>), of which the prototype will be used if it
8924 has one. The prototype (or lack thereof) supplied, in whichever form,
8925 does not need to match the actual callee referenced by the op tree.
8927 If the argument ops disagree with the prototype, for example by having
8928 an unacceptable number of arguments, a valid op tree is returned anyway.
8929 The error is reflected in the parser state, normally resulting in a single
8930 exception at the top level of parsing which covers all the compilation
8931 errors that occurred. In the error message, the callee is referred to
8932 by the name defined by the I<namegv> parameter.
8938 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8939 GV *namegv, SV *protosv)
8941 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8942 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8943 return ck_entersub_args_proto(entersubop, namegv, protosv);
8945 return ck_entersub_args_list(entersubop);
8949 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8951 Retrieves the function that will be used to fix up a call to I<cv>.
8952 Specifically, the function is applied to an C<entersub> op tree for a
8953 subroutine call, not marked with C<&>, where the callee can be identified
8954 at compile time as I<cv>.
8956 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8957 argument for it is returned in I<*ckobj_p>. The function is intended
8958 to be called in this manner:
8960 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8962 In this call, I<entersubop> is a pointer to the C<entersub> op,
8963 which may be replaced by the check function, and I<namegv> is a GV
8964 supplying the name that should be used by the check function to refer
8965 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8966 It is permitted to apply the check function in non-standard situations,
8967 such as to a call to a different subroutine or to a method call.
8969 By default, the function is
8970 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8971 and the SV parameter is I<cv> itself. This implements standard
8972 prototype processing. It can be changed, for a particular subroutine,
8973 by L</cv_set_call_checker>.
8979 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8982 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8983 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8985 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8986 *ckobj_p = callmg->mg_obj;
8988 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8994 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8996 Sets the function that will be used to fix up a call to I<cv>.
8997 Specifically, the function is applied to an C<entersub> op tree for a
8998 subroutine call, not marked with C<&>, where the callee can be identified
8999 at compile time as I<cv>.
9001 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9002 for it is supplied in I<ckobj>. The function is intended to be called
9005 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9007 In this call, I<entersubop> is a pointer to the C<entersub> op,
9008 which may be replaced by the check function, and I<namegv> is a GV
9009 supplying the name that should be used by the check function to refer
9010 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9011 It is permitted to apply the check function in non-standard situations,
9012 such as to a call to a different subroutine or to a method call.
9014 The current setting for a particular CV can be retrieved by
9015 L</cv_get_call_checker>.
9021 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9023 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9024 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9025 if (SvMAGICAL((SV*)cv))
9026 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9029 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9030 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9031 if (callmg->mg_flags & MGf_REFCOUNTED) {
9032 SvREFCNT_dec(callmg->mg_obj);
9033 callmg->mg_flags &= ~MGf_REFCOUNTED;
9035 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9036 callmg->mg_obj = ckobj;
9037 if (ckobj != (SV*)cv) {
9038 SvREFCNT_inc_simple_void_NN(ckobj);
9039 callmg->mg_flags |= MGf_REFCOUNTED;
9045 Perl_ck_subr(pTHX_ OP *o)
9051 PERL_ARGS_ASSERT_CK_SUBR;
9053 aop = cUNOPx(o)->op_first;
9054 if (!aop->op_sibling)
9055 aop = cUNOPx(aop)->op_first;
9056 aop = aop->op_sibling;
9057 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9058 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9059 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9061 o->op_private &= ~1;
9062 o->op_private |= OPpENTERSUB_HASTARG;
9063 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9064 if (PERLDB_SUB && PL_curstash != PL_debstash)
9065 o->op_private |= OPpENTERSUB_DB;
9066 if (cvop->op_type == OP_RV2CV) {
9067 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9069 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9070 if (aop->op_type == OP_CONST)
9071 aop->op_private &= ~OPpCONST_STRICT;
9072 else if (aop->op_type == OP_LIST) {
9073 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9074 if (sib && sib->op_type == OP_CONST)
9075 sib->op_private &= ~OPpCONST_STRICT;
9080 return ck_entersub_args_list(o);
9082 Perl_call_checker ckfun;
9084 cv_get_call_checker(cv, &ckfun, &ckobj);
9085 return ckfun(aTHX_ o, namegv, ckobj);
9090 Perl_ck_svconst(pTHX_ OP *o)
9092 PERL_ARGS_ASSERT_CK_SVCONST;
9093 PERL_UNUSED_CONTEXT;
9094 SvREADONLY_on(cSVOPo->op_sv);
9099 Perl_ck_chdir(pTHX_ OP *o)
9101 PERL_ARGS_ASSERT_CK_CHDIR;
9102 if (o->op_flags & OPf_KIDS) {
9103 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9105 if (kid && kid->op_type == OP_CONST &&
9106 (kid->op_private & OPpCONST_BARE))
9108 o->op_flags |= OPf_SPECIAL;
9109 kid->op_private &= ~OPpCONST_STRICT;
9116 Perl_ck_trunc(pTHX_ OP *o)
9118 PERL_ARGS_ASSERT_CK_TRUNC;
9120 if (o->op_flags & OPf_KIDS) {
9121 SVOP *kid = (SVOP*)cUNOPo->op_first;
9123 if (kid->op_type == OP_NULL)
9124 kid = (SVOP*)kid->op_sibling;
9125 if (kid && kid->op_type == OP_CONST &&
9126 (kid->op_private & OPpCONST_BARE))
9128 o->op_flags |= OPf_SPECIAL;
9129 kid->op_private &= ~OPpCONST_STRICT;
9136 Perl_ck_unpack(pTHX_ OP *o)
9138 OP *kid = cLISTOPo->op_first;
9140 PERL_ARGS_ASSERT_CK_UNPACK;
9142 if (kid->op_sibling) {
9143 kid = kid->op_sibling;
9144 if (!kid->op_sibling)
9145 kid->op_sibling = newDEFSVOP();
9151 Perl_ck_substr(pTHX_ OP *o)
9153 PERL_ARGS_ASSERT_CK_SUBSTR;
9156 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9157 OP *kid = cLISTOPo->op_first;
9159 if (kid->op_type == OP_NULL)
9160 kid = kid->op_sibling;
9162 kid->op_flags |= OPf_MOD;
9169 Perl_ck_each(pTHX_ OP *o)
9172 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9173 const unsigned orig_type = o->op_type;
9174 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9175 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9176 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9177 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9179 PERL_ARGS_ASSERT_CK_EACH;
9182 switch (kid->op_type) {
9188 CHANGE_TYPE(o, array_type);
9191 if (kid->op_private == OPpCONST_BARE
9192 || !SvROK(cSVOPx_sv(kid))
9193 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9194 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9196 /* we let ck_fun handle it */
9199 CHANGE_TYPE(o, ref_type);
9203 /* if treating as a reference, defer additional checks to runtime */
9204 return o->op_type == ref_type ? o : ck_fun(o);
9207 /* caller is supposed to assign the return to the
9208 container of the rep_op var */
9210 S_opt_scalarhv(pTHX_ OP *rep_op) {
9214 PERL_ARGS_ASSERT_OPT_SCALARHV;
9216 NewOp(1101, unop, 1, UNOP);
9217 unop->op_type = (OPCODE)OP_BOOLKEYS;
9218 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9219 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9220 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9221 unop->op_first = rep_op;
9222 unop->op_next = rep_op->op_next;
9223 rep_op->op_next = (OP*)unop;
9224 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9225 unop->op_sibling = rep_op->op_sibling;
9226 rep_op->op_sibling = NULL;
9227 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9228 if (rep_op->op_type == OP_PADHV) {
9229 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9230 rep_op->op_flags |= OPf_WANT_LIST;
9235 /* Checks if o acts as an in-place operator on an array. oright points to the
9236 * beginning of the right-hand side. Returns the left-hand side of the
9237 * assignment if o acts in-place, or NULL otherwise. */
9240 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9244 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9247 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9248 || oright->op_next != o
9249 || (oright->op_private & OPpLVAL_INTRO)
9253 /* o2 follows the chain of op_nexts through the LHS of the
9254 * assign (if any) to the aassign op itself */
9256 if (!o2 || o2->op_type != OP_NULL)
9259 if (!o2 || o2->op_type != OP_PUSHMARK)
9262 if (o2 && o2->op_type == OP_GV)
9265 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9266 || (o2->op_private & OPpLVAL_INTRO)
9271 if (!o2 || o2->op_type != OP_NULL)
9274 if (!o2 || o2->op_type != OP_AASSIGN
9275 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9278 /* check that the sort is the first arg on RHS of assign */
9280 o2 = cUNOPx(o2)->op_first;
9281 if (!o2 || o2->op_type != OP_NULL)
9283 o2 = cUNOPx(o2)->op_first;
9284 if (!o2 || o2->op_type != OP_PUSHMARK)
9286 if (o2->op_sibling != o)
9289 /* check the array is the same on both sides */
9290 if (oleft->op_type == OP_RV2AV) {
9291 if (oright->op_type != OP_RV2AV
9292 || !cUNOPx(oright)->op_first
9293 || cUNOPx(oright)->op_first->op_type != OP_GV
9294 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9295 cGVOPx_gv(cUNOPx(oright)->op_first)
9299 else if (oright->op_type != OP_PADAV
9300 || oright->op_targ != oleft->op_targ
9307 /* A peephole optimizer. We visit the ops in the order they're to execute.
9308 * See the comments at the top of this file for more details about when
9309 * peep() is called */
9312 Perl_rpeep(pTHX_ register OP *o)
9315 register OP* oldop = NULL;
9317 if (!o || o->op_opt)
9321 SAVEVPTR(PL_curcop);
9322 for (; o; o = o->op_next) {
9323 #if defined(PERL_MAD) && defined(USE_ITHREADS)
9324 MADPROP *mp = o->op_madprop;
9326 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
9327 OP *prop_op = (OP *) mp->mad_val;
9328 /* I *think* that this is roughly the right thing to do. It
9329 seems that sometimes the optree hooked into the madprops
9330 doesn't have its next pointers set, so it's not possible to
9331 use them to locate all the OPs needing a fixup. Possibly
9332 it's a bit overkill calling LINKLIST to do this, when we
9333 could instead iterate over the OPs (without changing them)
9334 the way op_linklist does internally. However, I'm not sure
9335 if there are corner cases where we have a chain of partially
9336 linked OPs. Or even if we do, does that matter? Or should
9337 we always iterate on op_first,op_next? */
9340 if (prop_op->op_opt)
9342 prop_op->op_opt = 1;
9343 switch (prop_op->op_type) {
9346 case OP_METHOD_NAMED:
9347 /* Duplicate the "relocate sv to the pad for thread
9348 safety" code, as otherwise an opfree of this madprop
9349 in the wrong thread will free the SV to the wrong
9351 if (((SVOP *)prop_op)->op_sv) {
9352 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9353 sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
9354 SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
9355 ((SVOP *)prop_op)->op_sv = NULL;
9359 } while ((prop_op = prop_op->op_next));
9366 /* By default, this op has now been optimised. A couple of cases below
9367 clear this again. */
9370 switch (o->op_type) {
9372 PL_curcop = ((COP*)o); /* for warnings */
9375 PL_curcop = ((COP*)o); /* for warnings */
9377 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9378 to carry two labels. For now, take the easier option, and skip
9379 this optimisation if the first NEXTSTATE has a label. */
9380 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9381 OP *nextop = o->op_next;
9382 while (nextop && nextop->op_type == OP_NULL)
9383 nextop = nextop->op_next;
9385 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9386 COP *firstcop = (COP *)o;
9387 COP *secondcop = (COP *)nextop;
9388 /* We want the COP pointed to by o (and anything else) to
9389 become the next COP down the line. */
9392 firstcop->op_next = secondcop->op_next;
9394 /* Now steal all its pointers, and duplicate the other
9396 firstcop->cop_line = secondcop->cop_line;
9398 firstcop->cop_stashpv = secondcop->cop_stashpv;
9399 firstcop->cop_file = secondcop->cop_file;
9401 firstcop->cop_stash = secondcop->cop_stash;
9402 firstcop->cop_filegv = secondcop->cop_filegv;
9404 firstcop->cop_hints = secondcop->cop_hints;
9405 firstcop->cop_seq = secondcop->cop_seq;
9406 firstcop->cop_warnings = secondcop->cop_warnings;
9407 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9410 secondcop->cop_stashpv = NULL;
9411 secondcop->cop_file = NULL;
9413 secondcop->cop_stash = NULL;
9414 secondcop->cop_filegv = NULL;
9416 secondcop->cop_warnings = NULL;
9417 secondcop->cop_hints_hash = NULL;
9419 /* If we use op_null(), and hence leave an ex-COP, some
9420 warnings are misreported. For example, the compile-time
9421 error in 'use strict; no strict refs;' */
9422 secondcop->op_type = OP_NULL;
9423 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9429 if (cSVOPo->op_private & OPpCONST_STRICT)
9430 no_bareword_allowed(o);
9433 case OP_METHOD_NAMED:
9434 /* Relocate sv to the pad for thread safety.
9435 * Despite being a "constant", the SV is written to,
9436 * for reference counts, sv_upgrade() etc. */
9438 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9439 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9440 /* If op_sv is already a PADTMP then it is being used by
9441 * some pad, so make a copy. */
9442 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9443 SvREADONLY_on(PAD_SVl(ix));
9444 SvREFCNT_dec(cSVOPo->op_sv);
9446 else if (o->op_type != OP_METHOD_NAMED
9447 && cSVOPo->op_sv == &PL_sv_undef) {
9448 /* PL_sv_undef is hack - it's unsafe to store it in the
9449 AV that is the pad, because av_fetch treats values of
9450 PL_sv_undef as a "free" AV entry and will merrily
9451 replace them with a new SV, causing pad_alloc to think
9452 that this pad slot is free. (When, clearly, it is not)
9454 SvOK_off(PAD_SVl(ix));
9455 SvPADTMP_on(PAD_SVl(ix));
9456 SvREADONLY_on(PAD_SVl(ix));
9459 SvREFCNT_dec(PAD_SVl(ix));
9460 SvPADTMP_on(cSVOPo->op_sv);
9461 PAD_SETSV(ix, cSVOPo->op_sv);
9462 /* XXX I don't know how this isn't readonly already. */
9463 SvREADONLY_on(PAD_SVl(ix));
9465 cSVOPo->op_sv = NULL;
9472 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9473 if (o->op_next->op_private & OPpTARGET_MY) {
9474 if (o->op_flags & OPf_STACKED) /* chained concats */
9475 break; /* ignore_optimization */
9477 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9478 o->op_targ = o->op_next->op_targ;
9479 o->op_next->op_targ = 0;
9480 o->op_private |= OPpTARGET_MY;
9483 op_null(o->op_next);
9487 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9488 break; /* Scalar stub must produce undef. List stub is noop */
9492 if (o->op_targ == OP_NEXTSTATE
9493 || o->op_targ == OP_DBSTATE)
9495 PL_curcop = ((COP*)o);
9497 /* XXX: We avoid setting op_seq here to prevent later calls
9498 to rpeep() from mistakenly concluding that optimisation
9499 has already occurred. This doesn't fix the real problem,
9500 though (See 20010220.007). AMS 20010719 */
9501 /* op_seq functionality is now replaced by op_opt */
9508 if (oldop && o->op_next) {
9509 oldop->op_next = o->op_next;
9517 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9518 OP* const pop = (o->op_type == OP_PADAV) ?
9519 o->op_next : o->op_next->op_next;
9521 if (pop && pop->op_type == OP_CONST &&
9522 ((PL_op = pop->op_next)) &&
9523 pop->op_next->op_type == OP_AELEM &&
9524 !(pop->op_next->op_private &
9525 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9526 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9531 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9532 no_bareword_allowed(pop);
9533 if (o->op_type == OP_GV)
9534 op_null(o->op_next);
9535 op_null(pop->op_next);
9537 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9538 o->op_next = pop->op_next->op_next;
9539 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9540 o->op_private = (U8)i;
9541 if (o->op_type == OP_GV) {
9544 o->op_type = OP_AELEMFAST;
9547 o->op_type = OP_AELEMFAST_LEX;
9552 if (o->op_next->op_type == OP_RV2SV) {
9553 if (!(o->op_next->op_private & OPpDEREF)) {
9554 op_null(o->op_next);
9555 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9557 o->op_next = o->op_next->op_next;
9558 o->op_type = OP_GVSV;
9559 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9562 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9563 GV * const gv = cGVOPo_gv;
9564 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9565 /* XXX could check prototype here instead of just carping */
9566 SV * const sv = sv_newmortal();
9567 gv_efullname3(sv, gv, NULL);
9568 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9569 "%"SVf"() called too early to check prototype",
9573 else if (o->op_next->op_type == OP_READLINE
9574 && o->op_next->op_next->op_type == OP_CONCAT
9575 && (o->op_next->op_next->op_flags & OPf_STACKED))
9577 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9578 o->op_type = OP_RCATLINE;
9579 o->op_flags |= OPf_STACKED;
9580 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9581 op_null(o->op_next->op_next);
9582 op_null(o->op_next);
9592 fop = cUNOP->op_first;
9600 fop = cLOGOP->op_first;
9601 sop = fop->op_sibling;
9602 while (cLOGOP->op_other->op_type == OP_NULL)
9603 cLOGOP->op_other = cLOGOP->op_other->op_next;
9604 CALL_RPEEP(cLOGOP->op_other);
9608 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9610 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9615 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9616 while (nop && nop->op_next) {
9617 switch (nop->op_next->op_type) {
9622 lop = nop = nop->op_next;
9633 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9634 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9635 cLOGOP->op_first = opt_scalarhv(fop);
9636 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9637 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9653 while (cLOGOP->op_other->op_type == OP_NULL)
9654 cLOGOP->op_other = cLOGOP->op_other->op_next;
9655 CALL_RPEEP(cLOGOP->op_other);
9660 while (cLOOP->op_redoop->op_type == OP_NULL)
9661 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9662 CALL_RPEEP(cLOOP->op_redoop);
9663 while (cLOOP->op_nextop->op_type == OP_NULL)
9664 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9665 CALL_RPEEP(cLOOP->op_nextop);
9666 while (cLOOP->op_lastop->op_type == OP_NULL)
9667 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9668 CALL_RPEEP(cLOOP->op_lastop);
9672 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9673 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9674 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9675 cPMOP->op_pmstashstartu.op_pmreplstart
9676 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9677 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9681 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9682 && ckWARN(WARN_SYNTAX))
9684 if (o->op_next->op_sibling) {
9685 const OPCODE type = o->op_next->op_sibling->op_type;
9686 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9687 const line_t oldline = CopLINE(PL_curcop);
9688 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9689 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9690 "Statement unlikely to be reached");
9691 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9692 "\t(Maybe you meant system() when you said exec()?)\n");
9693 CopLINE_set(PL_curcop, oldline);
9704 const char *key = NULL;
9707 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9710 /* Make the CONST have a shared SV */
9711 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9712 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9713 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9714 key = SvPV_const(sv, keylen);
9715 lexname = newSVpvn_share(key,
9716 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9722 if ((o->op_private & (OPpLVAL_INTRO)))
9725 rop = (UNOP*)((BINOP*)o)->op_first;
9726 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9728 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9729 if (!SvPAD_TYPED(lexname))
9731 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9732 if (!fields || !GvHV(*fields))
9734 key = SvPV_const(*svp, keylen);
9735 if (!hv_fetch(GvHV(*fields), key,
9736 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9738 Perl_croak(aTHX_ "No such class field \"%s\" "
9739 "in variable %s of type %s",
9740 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9753 SVOP *first_key_op, *key_op;
9755 if ((o->op_private & (OPpLVAL_INTRO))
9756 /* I bet there's always a pushmark... */
9757 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9758 /* hmmm, no optimization if list contains only one key. */
9760 rop = (UNOP*)((LISTOP*)o)->op_last;
9761 if (rop->op_type != OP_RV2HV)
9763 if (rop->op_first->op_type == OP_PADSV)
9764 /* @$hash{qw(keys here)} */
9765 rop = (UNOP*)rop->op_first;
9767 /* @{$hash}{qw(keys here)} */
9768 if (rop->op_first->op_type == OP_SCOPE
9769 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9771 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9777 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9778 if (!SvPAD_TYPED(lexname))
9780 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9781 if (!fields || !GvHV(*fields))
9783 /* Again guessing that the pushmark can be jumped over.... */
9784 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9785 ->op_first->op_sibling;
9786 for (key_op = first_key_op; key_op;
9787 key_op = (SVOP*)key_op->op_sibling) {
9788 if (key_op->op_type != OP_CONST)
9790 svp = cSVOPx_svp(key_op);
9791 key = SvPV_const(*svp, keylen);
9792 if (!hv_fetch(GvHV(*fields), key,
9793 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9795 Perl_croak(aTHX_ "No such class field \"%s\" "
9796 "in variable %s of type %s",
9797 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9808 ( oldop->op_type == OP_AELEM
9809 || oldop->op_type == OP_PADSV
9810 || oldop->op_type == OP_RV2SV
9811 || oldop->op_type == OP_RV2GV
9812 || oldop->op_type == OP_HELEM
9814 && (oldop->op_private & OPpDEREF)
9816 || ( oldop->op_type == OP_ENTERSUB
9817 && oldop->op_private & OPpENTERSUB_DEREF )
9820 o->op_private |= OPpDEREFed;
9824 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9828 /* check that RHS of sort is a single plain array */
9829 OP *oright = cUNOPo->op_first;
9830 if (!oright || oright->op_type != OP_PUSHMARK)
9833 /* reverse sort ... can be optimised. */
9834 if (!cUNOPo->op_sibling) {
9835 /* Nothing follows us on the list. */
9836 OP * const reverse = o->op_next;
9838 if (reverse->op_type == OP_REVERSE &&
9839 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9840 OP * const pushmark = cUNOPx(reverse)->op_first;
9841 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9842 && (cUNOPx(pushmark)->op_sibling == o)) {
9843 /* reverse -> pushmark -> sort */
9844 o->op_private |= OPpSORT_REVERSE;
9846 pushmark->op_next = oright->op_next;
9852 /* make @a = sort @a act in-place */
9854 oright = cUNOPx(oright)->op_sibling;
9857 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9858 oright = cUNOPx(oright)->op_sibling;
9861 oleft = is_inplace_av(o, oright);
9865 /* transfer MODishness etc from LHS arg to RHS arg */
9866 oright->op_flags = oleft->op_flags;
9867 o->op_private |= OPpSORT_INPLACE;
9869 /* excise push->gv->rv2av->null->aassign */
9870 o2 = o->op_next->op_next;
9871 op_null(o2); /* PUSHMARK */
9873 if (o2->op_type == OP_GV) {
9874 op_null(o2); /* GV */
9877 op_null(o2); /* RV2AV or PADAV */
9878 o2 = o2->op_next->op_next;
9879 op_null(o2); /* AASSIGN */
9881 o->op_next = o2->op_next;
9887 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9890 LISTOP *enter, *exlist;
9892 /* @a = reverse @a */
9893 if ((oright = cLISTOPo->op_first)
9894 && (oright->op_type == OP_PUSHMARK)
9895 && (oright = oright->op_sibling)
9896 && (oleft = is_inplace_av(o, oright))) {
9899 /* transfer MODishness etc from LHS arg to RHS arg */
9900 oright->op_flags = oleft->op_flags;
9901 o->op_private |= OPpREVERSE_INPLACE;
9903 /* excise push->gv->rv2av->null->aassign */
9904 o2 = o->op_next->op_next;
9905 op_null(o2); /* PUSHMARK */
9907 if (o2->op_type == OP_GV) {
9908 op_null(o2); /* GV */
9911 op_null(o2); /* RV2AV or PADAV */
9912 o2 = o2->op_next->op_next;
9913 op_null(o2); /* AASSIGN */
9915 o->op_next = o2->op_next;
9919 enter = (LISTOP *) o->op_next;
9922 if (enter->op_type == OP_NULL) {
9923 enter = (LISTOP *) enter->op_next;
9927 /* for $a (...) will have OP_GV then OP_RV2GV here.
9928 for (...) just has an OP_GV. */
9929 if (enter->op_type == OP_GV) {
9930 gvop = (OP *) enter;
9931 enter = (LISTOP *) enter->op_next;
9934 if (enter->op_type == OP_RV2GV) {
9935 enter = (LISTOP *) enter->op_next;
9941 if (enter->op_type != OP_ENTERITER)
9944 iter = enter->op_next;
9945 if (!iter || iter->op_type != OP_ITER)
9948 expushmark = enter->op_first;
9949 if (!expushmark || expushmark->op_type != OP_NULL
9950 || expushmark->op_targ != OP_PUSHMARK)
9953 exlist = (LISTOP *) expushmark->op_sibling;
9954 if (!exlist || exlist->op_type != OP_NULL
9955 || exlist->op_targ != OP_LIST)
9958 if (exlist->op_last != o) {
9959 /* Mmm. Was expecting to point back to this op. */
9962 theirmark = exlist->op_first;
9963 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9966 if (theirmark->op_sibling != o) {
9967 /* There's something between the mark and the reverse, eg
9968 for (1, reverse (...))
9973 ourmark = ((LISTOP *)o)->op_first;
9974 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9977 ourlast = ((LISTOP *)o)->op_last;
9978 if (!ourlast || ourlast->op_next != o)
9981 rv2av = ourmark->op_sibling;
9982 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9983 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9984 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9985 /* We're just reversing a single array. */
9986 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9987 enter->op_flags |= OPf_STACKED;
9990 /* We don't have control over who points to theirmark, so sacrifice
9992 theirmark->op_next = ourmark->op_next;
9993 theirmark->op_flags = ourmark->op_flags;
9994 ourlast->op_next = gvop ? gvop : (OP *) enter;
9997 enter->op_private |= OPpITER_REVERSED;
9998 iter->op_private |= OPpITER_REVERSED;
10005 UNOP *refgen, *rv2cv;
10008 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
10011 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
10014 rv2gv = ((BINOP *)o)->op_last;
10015 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
10018 refgen = (UNOP *)((BINOP *)o)->op_first;
10020 if (!refgen || refgen->op_type != OP_REFGEN)
10023 exlist = (LISTOP *)refgen->op_first;
10024 if (!exlist || exlist->op_type != OP_NULL
10025 || exlist->op_targ != OP_LIST)
10028 if (exlist->op_first->op_type != OP_PUSHMARK)
10031 rv2cv = (UNOP*)exlist->op_last;
10033 if (rv2cv->op_type != OP_RV2CV)
10036 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10037 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10038 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10040 o->op_private |= OPpASSIGN_CV_TO_GV;
10041 rv2gv->op_private |= OPpDONT_INIT_GV;
10042 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10050 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10051 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10056 Perl_cpeep_t cpeep =
10057 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10059 cpeep(aTHX_ o, oldop);
10070 Perl_peep(pTHX_ register OP *o)
10076 =head1 Custom Operators
10078 =for apidoc Ao||custom_op_xop
10079 Return the XOP structure for a given custom op. This function should be
10080 considered internal to OP_NAME and the other access macros: use them instead.
10086 Perl_custom_op_xop(pTHX_ const OP *o)
10092 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10094 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10095 assert(o->op_type == OP_CUSTOM);
10097 /* This is wrong. It assumes a function pointer can be cast to IV,
10098 * which isn't guaranteed, but this is what the old custom OP code
10099 * did. In principle it should be safer to Copy the bytes of the
10100 * pointer into a PV: since the new interface is hidden behind
10101 * functions, this can be changed later if necessary. */
10102 /* Change custom_op_xop if this ever happens */
10103 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10106 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10108 /* assume noone will have just registered a desc */
10109 if (!he && PL_custom_op_names &&
10110 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10115 /* XXX does all this need to be shared mem? */
10116 Newxz(xop, 1, XOP);
10117 pv = SvPV(HeVAL(he), l);
10118 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10119 if (PL_custom_op_descs &&
10120 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10122 pv = SvPV(HeVAL(he), l);
10123 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10125 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10129 if (!he) return &xop_null;
10131 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10136 =for apidoc Ao||custom_op_register
10137 Register a custom op. See L<perlguts/"Custom Operators">.
10143 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10147 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10149 /* see the comment in custom_op_xop */
10150 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10152 if (!PL_custom_ops)
10153 PL_custom_ops = newHV();
10155 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10156 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10161 /* Efficient sub that returns a constant scalar value. */
10163 const_sv_xsub(pTHX_ CV* cv)
10167 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10171 /* diag_listed_as: SKIPME */
10172 Perl_croak(aTHX_ "usage: %s::%s()",
10173 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10186 * c-indentation-style: bsd
10187 * c-basic-offset: 4
10188 * indent-tabs-mode: t
10191 * ex: set ts=8 sts=4 sw=4 noet: