4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 /* if (o->op_madprop && o->op_madprop->mad_next)
552 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
553 "modification of a read only value" for a reason I can't fathom why.
554 It's the "" stringification of $_, where $_ was set to '' in a foreach
555 loop, but it defies simplification into a small test case.
556 However, commenting them out has caused ext/List/Util/t/weak.t to fail
559 mad_free(o->op_madprop);
565 switch (o->op_type) {
566 case OP_NULL: /* Was holding old type, if any. */
567 if (PL_madskills && o->op_targ != OP_NULL) {
568 o->op_type = (Optype)o->op_targ;
573 case OP_ENTEREVAL: /* Was holding hints. */
577 if (!(o->op_flags & OPf_REF)
578 || (PL_check[o->op_type] != Perl_ck_ftst))
584 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
585 /* not an OP_PADAV replacement */
586 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
591 /* It's possible during global destruction that the GV is freed
592 before the optree. Whilst the SvREFCNT_inc is happy to bump from
593 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
594 will trigger an assertion failure, because the entry to sv_clear
595 checks that the scalar is not already freed. A check of for
596 !SvIS_FREED(gv) turns out to be invalid, because during global
597 destruction the reference count can be forced down to zero
598 (with SVf_BREAK set). In which case raising to 1 and then
599 dropping to 0 triggers cleanup before it should happen. I
600 *think* that this might actually be a general, systematic,
601 weakness of the whole idea of SVf_BREAK, in that code *is*
602 allowed to raise and lower references during global destruction,
603 so any *valid* code that happens to do this during global
604 destruction might well trigger premature cleanup. */
605 bool still_valid = gv && SvREFCNT(gv);
608 SvREFCNT_inc_simple_void(gv);
610 if (cPADOPo->op_padix > 0) {
611 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
612 * may still exist on the pad */
613 pad_swipe(cPADOPo->op_padix, TRUE);
614 cPADOPo->op_padix = 0;
617 SvREFCNT_dec(cSVOPo->op_sv);
618 cSVOPo->op_sv = NULL;
621 int try_downgrade = SvREFCNT(gv) == 2;
624 gv_try_downgrade(gv);
628 case OP_METHOD_NAMED:
631 SvREFCNT_dec(cSVOPo->op_sv);
632 cSVOPo->op_sv = NULL;
635 Even if op_clear does a pad_free for the target of the op,
636 pad_free doesn't actually remove the sv that exists in the pad;
637 instead it lives on. This results in that it could be reused as
638 a target later on when the pad was reallocated.
641 pad_swipe(o->op_targ,1);
650 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
655 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
657 if (cPADOPo->op_padix > 0) {
658 pad_swipe(cPADOPo->op_padix, TRUE);
659 cPADOPo->op_padix = 0;
662 SvREFCNT_dec(cSVOPo->op_sv);
663 cSVOPo->op_sv = NULL;
667 PerlMemShared_free(cPVOPo->op_pv);
668 cPVOPo->op_pv = NULL;
672 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
676 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
677 /* No GvIN_PAD_off here, because other references may still
678 * exist on the pad */
679 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
682 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
688 forget_pmop(cPMOPo, 1);
689 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
690 /* we use the same protection as the "SAFE" version of the PM_ macros
691 * here since sv_clean_all might release some PMOPs
692 * after PL_regex_padav has been cleared
693 * and the clearing of PL_regex_padav needs to
694 * happen before sv_clean_all
697 if(PL_regex_pad) { /* We could be in destruction */
698 const IV offset = (cPMOPo)->op_pmoffset;
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PL_regex_pad[offset] = &PL_sv_undef;
701 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
705 ReREFCNT_dec(PM_GETRE(cPMOPo));
706 PM_SETRE(cPMOPo, NULL);
712 if (o->op_targ > 0) {
713 pad_free(o->op_targ);
719 S_cop_free(pTHX_ COP* cop)
721 PERL_ARGS_ASSERT_COP_FREE;
725 if (! specialWARN(cop->cop_warnings))
726 PerlMemShared_free(cop->cop_warnings);
727 cophh_free(CopHINTHASH_get(cop));
731 S_forget_pmop(pTHX_ PMOP *const o
737 HV * const pmstash = PmopSTASH(o);
739 PERL_ARGS_ASSERT_FORGET_PMOP;
741 if (pmstash && !SvIS_FREED(pmstash)) {
742 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
744 PMOP **const array = (PMOP**) mg->mg_ptr;
745 U32 count = mg->mg_len / sizeof(PMOP**);
750 /* Found it. Move the entry at the end to overwrite it. */
751 array[i] = array[--count];
752 mg->mg_len = count * sizeof(PMOP**);
753 /* Could realloc smaller at this point always, but probably
754 not worth it. Probably worth free()ing if we're the
757 Safefree(mg->mg_ptr);
774 S_find_and_forget_pmops(pTHX_ OP *o)
776 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
778 if (o->op_flags & OPf_KIDS) {
779 OP *kid = cUNOPo->op_first;
781 switch (kid->op_type) {
786 forget_pmop((PMOP*)kid, 0);
788 find_and_forget_pmops(kid);
789 kid = kid->op_sibling;
795 Perl_op_null(pTHX_ OP *o)
799 PERL_ARGS_ASSERT_OP_NULL;
801 if (o->op_type == OP_NULL)
805 o->op_targ = o->op_type;
806 o->op_type = OP_NULL;
807 o->op_ppaddr = PL_ppaddr[OP_NULL];
811 Perl_op_refcnt_lock(pTHX)
819 Perl_op_refcnt_unlock(pTHX)
826 /* Contextualizers */
829 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
831 Applies a syntactic context to an op tree representing an expression.
832 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
833 or C<G_VOID> to specify the context to apply. The modified op tree
840 Perl_op_contextualize(pTHX_ OP *o, I32 context)
842 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
844 case G_SCALAR: return scalar(o);
845 case G_ARRAY: return list(o);
846 case G_VOID: return scalarvoid(o);
848 Perl_croak(aTHX_ "panic: op_contextualize bad context");
854 =head1 Optree Manipulation Functions
856 =for apidoc Am|OP*|op_linklist|OP *o
857 This function is the implementation of the L</LINKLIST> macro. It should
858 not be called directly.
864 Perl_op_linklist(pTHX_ OP *o)
868 PERL_ARGS_ASSERT_OP_LINKLIST;
873 /* establish postfix order */
874 first = cUNOPo->op_first;
877 o->op_next = LINKLIST(first);
880 if (kid->op_sibling) {
881 kid->op_next = LINKLIST(kid->op_sibling);
882 kid = kid->op_sibling;
896 S_scalarkids(pTHX_ OP *o)
898 if (o && o->op_flags & OPf_KIDS) {
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 S_scalarboolean(pTHX_ OP *o)
911 PERL_ARGS_ASSERT_SCALARBOOLEAN;
913 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
914 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
915 if (ckWARN(WARN_SYNTAX)) {
916 const line_t oldline = CopLINE(PL_curcop);
918 if (PL_parser && PL_parser->copline != NOLINE)
919 CopLINE_set(PL_curcop, PL_parser->copline);
920 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
921 CopLINE_set(PL_curcop, oldline);
928 Perl_scalar(pTHX_ OP *o)
933 /* assumes no premature commitment */
934 if (!o || (PL_parser && PL_parser->error_count)
935 || (o->op_flags & OPf_WANT)
936 || o->op_type == OP_RETURN)
941 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
943 switch (o->op_type) {
945 scalar(cBINOPo->op_first);
950 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
960 if (o->op_flags & OPf_KIDS) {
961 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
967 kid = cLISTOPo->op_first;
969 kid = kid->op_sibling;
972 OP *sib = kid->op_sibling;
973 if (sib && kid->op_type != OP_LEAVEWHEN) {
974 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
984 PL_curcop = &PL_compiling;
989 kid = cLISTOPo->op_first;
992 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
999 Perl_scalarvoid(pTHX_ OP *o)
1003 const char* useless = NULL;
1007 PERL_ARGS_ASSERT_SCALARVOID;
1009 /* trailing mad null ops don't count as "there" for void processing */
1011 o->op_type != OP_NULL &&
1013 o->op_sibling->op_type == OP_NULL)
1016 for (sib = o->op_sibling;
1017 sib && sib->op_type == OP_NULL;
1018 sib = sib->op_sibling) ;
1024 if (o->op_type == OP_NEXTSTATE
1025 || o->op_type == OP_DBSTATE
1026 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1027 || o->op_targ == OP_DBSTATE)))
1028 PL_curcop = (COP*)o; /* for warning below */
1030 /* assumes no premature commitment */
1031 want = o->op_flags & OPf_WANT;
1032 if ((want && want != OPf_WANT_SCALAR)
1033 || (PL_parser && PL_parser->error_count)
1034 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1039 if ((o->op_private & OPpTARGET_MY)
1040 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1042 return scalar(o); /* As if inside SASSIGN */
1045 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1047 switch (o->op_type) {
1049 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1053 if (o->op_flags & OPf_STACKED)
1057 if (o->op_private == 4)
1100 case OP_GETSOCKNAME:
1101 case OP_GETPEERNAME:
1106 case OP_GETPRIORITY:
1130 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1131 /* Otherwise it's "Useless use of grep iterator" */
1132 useless = OP_DESC(o);
1136 kid = cLISTOPo->op_first;
1137 if (kid && kid->op_type == OP_PUSHRE
1139 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1141 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1143 useless = OP_DESC(o);
1147 kid = cUNOPo->op_first;
1148 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1149 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1152 useless = "negative pattern binding (!~)";
1156 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1157 useless = "non-destructive substitution (s///r)";
1161 useless = "non-destructive transliteration (tr///r)";
1168 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1169 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1170 useless = "a variable";
1175 if (cSVOPo->op_private & OPpCONST_STRICT)
1176 no_bareword_allowed(o);
1178 if (ckWARN(WARN_VOID)) {
1180 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1181 "a constant (%"SVf")", sv));
1182 useless = SvPV_nolen(msv);
1185 useless = "a constant (undef)";
1186 if (o->op_private & OPpCONST_ARYBASE)
1188 /* don't warn on optimised away booleans, eg
1189 * use constant Foo, 5; Foo || print; */
1190 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1192 /* the constants 0 and 1 are permitted as they are
1193 conventionally used as dummies in constructs like
1194 1 while some_condition_with_side_effects; */
1195 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1197 else if (SvPOK(sv)) {
1198 /* perl4's way of mixing documentation and code
1199 (before the invention of POD) was based on a
1200 trick to mix nroff and perl code. The trick was
1201 built upon these three nroff macros being used in
1202 void context. The pink camel has the details in
1203 the script wrapman near page 319. */
1204 const char * const maybe_macro = SvPVX_const(sv);
1205 if (strnEQ(maybe_macro, "di", 2) ||
1206 strnEQ(maybe_macro, "ds", 2) ||
1207 strnEQ(maybe_macro, "ig", 2))
1212 op_null(o); /* don't execute or even remember it */
1216 o->op_type = OP_PREINC; /* pre-increment is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1221 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1222 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1226 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1227 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1231 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1232 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1237 kid = cLOGOPo->op_first;
1238 if (kid->op_type == OP_NOT
1239 && (kid->op_flags & OPf_KIDS)
1241 if (o->op_type == OP_AND) {
1243 o->op_ppaddr = PL_ppaddr[OP_OR];
1245 o->op_type = OP_AND;
1246 o->op_ppaddr = PL_ppaddr[OP_AND];
1255 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1260 if (o->op_flags & OPf_STACKED)
1267 if (!(o->op_flags & OPf_KIDS))
1278 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1288 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1293 S_listkids(pTHX_ OP *o)
1295 if (o && o->op_flags & OPf_KIDS) {
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1304 Perl_list(pTHX_ OP *o)
1309 /* assumes no premature commitment */
1310 if (!o || (o->op_flags & OPf_WANT)
1311 || (PL_parser && PL_parser->error_count)
1312 || o->op_type == OP_RETURN)
1317 if ((o->op_private & OPpTARGET_MY)
1318 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1320 return o; /* As if inside SASSIGN */
1323 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1325 switch (o->op_type) {
1328 list(cBINOPo->op_first);
1333 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1341 if (!(o->op_flags & OPf_KIDS))
1343 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1344 list(cBINOPo->op_first);
1345 return gen_constant_list(o);
1352 kid = cLISTOPo->op_first;
1354 kid = kid->op_sibling;
1357 OP *sib = kid->op_sibling;
1358 if (sib && kid->op_type != OP_LEAVEWHEN) {
1359 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1369 PL_curcop = &PL_compiling;
1373 kid = cLISTOPo->op_first;
1380 S_scalarseq(pTHX_ OP *o)
1384 const OPCODE type = o->op_type;
1386 if (type == OP_LINESEQ || type == OP_SCOPE ||
1387 type == OP_LEAVE || type == OP_LEAVETRY)
1390 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1391 if (kid->op_sibling) {
1395 PL_curcop = &PL_compiling;
1397 o->op_flags &= ~OPf_PARENS;
1398 if (PL_hints & HINT_BLOCK_SCOPE)
1399 o->op_flags |= OPf_PARENS;
1402 o = newOP(OP_STUB, 0);
1407 S_modkids(pTHX_ OP *o, I32 type)
1409 if (o && o->op_flags & OPf_KIDS) {
1411 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1412 op_lvalue(kid, type);
1418 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1420 Propagate lvalue ("modifiable") context to an op and its children.
1421 I<type> represents the context type, roughly based on the type of op that
1422 would do the modifying, although C<local()> is represented by OP_NULL,
1423 because it has no op type of its own (it is signalled by a flag on
1426 This function detects things that can't be modified, such as C<$x+1>, and
1427 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1428 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1430 It also flags things that need to behave specially in an lvalue context,
1431 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1437 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1441 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1444 if (!o || (PL_parser && PL_parser->error_count))
1447 if ((o->op_private & OPpTARGET_MY)
1448 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1453 switch (o->op_type) {
1459 if (!(o->op_private & OPpCONST_ARYBASE))
1462 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1463 CopARYBASE_set(&PL_compiling,
1464 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1468 SAVECOPARYBASE(&PL_compiling);
1469 CopARYBASE_set(&PL_compiling, 0);
1471 else if (type == OP_REFGEN)
1474 Perl_croak(aTHX_ "That use of $[ is unsupported");
1477 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1481 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1482 !(o->op_flags & OPf_STACKED)) {
1483 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1484 /* The default is to set op_private to the number of children,
1485 which for a UNOP such as RV2CV is always 1. And w're using
1486 the bit for a flag in RV2CV, so we need it clear. */
1487 o->op_private &= ~1;
1488 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1489 assert(cUNOPo->op_first->op_type == OP_NULL);
1490 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1493 else if (o->op_private & OPpENTERSUB_NOMOD)
1495 else { /* lvalue subroutine call */
1496 o->op_private |= OPpLVAL_INTRO;
1497 PL_modcount = RETURN_UNLIMITED_NUMBER;
1498 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1499 /* Backward compatibility mode: */
1500 o->op_private |= OPpENTERSUB_INARGS;
1503 else { /* Compile-time error message: */
1504 OP *kid = cUNOPo->op_first;
1508 if (kid->op_type != OP_PUSHMARK) {
1509 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1511 "panic: unexpected lvalue entersub "
1512 "args: type/targ %ld:%"UVuf,
1513 (long)kid->op_type, (UV)kid->op_targ);
1514 kid = kLISTOP->op_first;
1516 while (kid->op_sibling)
1517 kid = kid->op_sibling;
1518 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1520 if (kid->op_type == OP_METHOD_NAMED
1521 || kid->op_type == OP_METHOD)
1525 NewOp(1101, newop, 1, UNOP);
1526 newop->op_type = OP_RV2CV;
1527 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1528 newop->op_first = NULL;
1529 newop->op_next = (OP*)newop;
1530 kid->op_sibling = (OP*)newop;
1531 newop->op_private |= OPpLVAL_INTRO;
1532 newop->op_private &= ~1;
1536 if (kid->op_type != OP_RV2CV)
1538 "panic: unexpected lvalue entersub "
1539 "entry via type/targ %ld:%"UVuf,
1540 (long)kid->op_type, (UV)kid->op_targ);
1541 kid->op_private |= OPpLVAL_INTRO;
1542 break; /* Postpone until runtime */
1546 kid = kUNOP->op_first;
1547 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1548 kid = kUNOP->op_first;
1549 if (kid->op_type == OP_NULL)
1551 "Unexpected constant lvalue entersub "
1552 "entry via type/targ %ld:%"UVuf,
1553 (long)kid->op_type, (UV)kid->op_targ);
1554 if (kid->op_type != OP_GV) {
1555 /* Restore RV2CV to check lvalueness */
1557 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1558 okid->op_next = kid->op_next;
1559 kid->op_next = okid;
1562 okid->op_next = NULL;
1563 okid->op_type = OP_RV2CV;
1565 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1566 okid->op_private |= OPpLVAL_INTRO;
1567 okid->op_private &= ~1;
1571 cv = GvCV(kGVOP_gv);
1581 /* grep, foreach, subcalls, refgen */
1582 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1584 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1585 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1587 : (o->op_type == OP_ENTERSUB
1588 ? "non-lvalue subroutine call"
1590 type ? PL_op_desc[type] : "local"));
1604 case OP_RIGHT_SHIFT:
1613 if (!(o->op_flags & OPf_STACKED))
1620 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1621 op_lvalue(kid, type);
1626 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1627 PL_modcount = RETURN_UNLIMITED_NUMBER;
1628 return o; /* Treat \(@foo) like ordinary list. */
1632 if (scalar_mod_type(o, type))
1634 ref(cUNOPo->op_first, o->op_type);
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1645 PL_modcount = RETURN_UNLIMITED_NUMBER;
1648 PL_hints |= HINT_BLOCK_SCOPE;
1649 if (type == OP_LEAVESUBLV)
1650 o->op_private |= OPpMAYBE_LVSUB;
1654 ref(cUNOPo->op_first, o->op_type);
1658 PL_hints |= HINT_BLOCK_SCOPE;
1673 PL_modcount = RETURN_UNLIMITED_NUMBER;
1674 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1675 return o; /* Treat \(@foo) like ordinary list. */
1676 if (scalar_mod_type(o, type))
1678 if (type == OP_LEAVESUBLV)
1679 o->op_private |= OPpMAYBE_LVSUB;
1683 if (!type) /* local() */
1684 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1685 PAD_COMPNAME_PV(o->op_targ));
1693 if (type != OP_SASSIGN)
1697 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1702 if (type == OP_LEAVESUBLV)
1703 o->op_private |= OPpMAYBE_LVSUB;
1705 pad_free(o->op_targ);
1706 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1707 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1708 if (o->op_flags & OPf_KIDS)
1709 op_lvalue(cBINOPo->op_first->op_sibling, type);
1714 ref(cBINOPo->op_first, o->op_type);
1715 if (type == OP_ENTERSUB &&
1716 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1717 o->op_private |= OPpLVAL_DEFER;
1718 if (type == OP_LEAVESUBLV)
1719 o->op_private |= OPpMAYBE_LVSUB;
1729 if (o->op_flags & OPf_KIDS)
1730 op_lvalue(cLISTOPo->op_last, type);
1735 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1737 else if (!(o->op_flags & OPf_KIDS))
1739 if (o->op_targ != OP_LIST) {
1740 op_lvalue(cBINOPo->op_first, type);
1746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1747 op_lvalue(kid, type);
1751 if (type != OP_LEAVESUBLV)
1753 break; /* op_lvalue()ing was handled by ck_return() */
1756 /* [20011101.069] File test operators interpret OPf_REF to mean that
1757 their argument is a filehandle; thus \stat(".") should not set
1759 if (type == OP_REFGEN &&
1760 PL_check[o->op_type] == Perl_ck_ftst)
1763 if (type != OP_LEAVESUBLV)
1764 o->op_flags |= OPf_MOD;
1766 if (type == OP_AASSIGN || type == OP_SASSIGN)
1767 o->op_flags |= OPf_SPECIAL|OPf_REF;
1768 else if (!type) { /* local() */
1771 o->op_private |= OPpLVAL_INTRO;
1772 o->op_flags &= ~OPf_SPECIAL;
1773 PL_hints |= HINT_BLOCK_SCOPE;
1778 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1779 "Useless localization of %s", OP_DESC(o));
1782 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1783 && type != OP_LEAVESUBLV)
1784 o->op_flags |= OPf_REF;
1788 /* Do not use this. It will be removed after 5.14. */
1790 Perl_mod(pTHX_ OP *o, I32 type)
1792 return op_lvalue(o,type);
1797 S_scalar_mod_type(const OP *o, I32 type)
1799 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1803 if (o->op_type == OP_RV2GV)
1827 case OP_RIGHT_SHIFT:
1848 S_is_handle_constructor(const OP *o, I32 numargs)
1850 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1852 switch (o->op_type) {
1860 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1873 S_refkids(pTHX_ OP *o, I32 type)
1875 if (o && o->op_flags & OPf_KIDS) {
1877 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1884 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1889 PERL_ARGS_ASSERT_DOREF;
1891 if (!o || (PL_parser && PL_parser->error_count))
1894 switch (o->op_type) {
1896 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1897 !(o->op_flags & OPf_STACKED)) {
1898 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1899 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1900 assert(cUNOPo->op_first->op_type == OP_NULL);
1901 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1902 o->op_flags |= OPf_SPECIAL;
1903 o->op_private &= ~1;
1908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1909 doref(kid, type, set_op_ref);
1912 if (type == OP_DEFINED)
1913 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1914 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1917 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1918 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1919 : type == OP_RV2HV ? OPpDEREF_HV
1921 o->op_flags |= OPf_MOD;
1928 o->op_flags |= OPf_REF;
1931 if (type == OP_DEFINED)
1932 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1933 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1939 o->op_flags |= OPf_REF;
1944 if (!(o->op_flags & OPf_KIDS))
1946 doref(cBINOPo->op_first, type, set_op_ref);
1950 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1951 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1952 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1953 : type == OP_RV2HV ? OPpDEREF_HV
1955 o->op_flags |= OPf_MOD;
1965 if (!(o->op_flags & OPf_KIDS))
1967 doref(cLISTOPo->op_last, type, set_op_ref);
1977 S_dup_attrlist(pTHX_ OP *o)
1982 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1984 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1985 * where the first kid is OP_PUSHMARK and the remaining ones
1986 * are OP_CONST. We need to push the OP_CONST values.
1988 if (o->op_type == OP_CONST)
1989 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1991 else if (o->op_type == OP_NULL)
1995 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1997 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1998 if (o->op_type == OP_CONST)
1999 rop = op_append_elem(OP_LIST, rop,
2000 newSVOP(OP_CONST, o->op_flags,
2001 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2008 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2013 PERL_ARGS_ASSERT_APPLY_ATTRS;
2015 /* fake up C<use attributes $pkg,$rv,@attrs> */
2016 ENTER; /* need to protect against side-effects of 'use' */
2017 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2019 #define ATTRSMODULE "attributes"
2020 #define ATTRSMODULE_PM "attributes.pm"
2023 /* Don't force the C<use> if we don't need it. */
2024 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2025 if (svp && *svp != &PL_sv_undef)
2026 NOOP; /* already in %INC */
2028 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2029 newSVpvs(ATTRSMODULE), NULL);
2032 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2033 newSVpvs(ATTRSMODULE),
2035 op_prepend_elem(OP_LIST,
2036 newSVOP(OP_CONST, 0, stashsv),
2037 op_prepend_elem(OP_LIST,
2038 newSVOP(OP_CONST, 0,
2040 dup_attrlist(attrs))));
2046 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2049 OP *pack, *imop, *arg;
2052 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2057 assert(target->op_type == OP_PADSV ||
2058 target->op_type == OP_PADHV ||
2059 target->op_type == OP_PADAV);
2061 /* Ensure that attributes.pm is loaded. */
2062 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2064 /* Need package name for method call. */
2065 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2067 /* Build up the real arg-list. */
2068 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2070 arg = newOP(OP_PADSV, 0);
2071 arg->op_targ = target->op_targ;
2072 arg = op_prepend_elem(OP_LIST,
2073 newSVOP(OP_CONST, 0, stashsv),
2074 op_prepend_elem(OP_LIST,
2075 newUNOP(OP_REFGEN, 0,
2076 op_lvalue(arg, OP_REFGEN)),
2077 dup_attrlist(attrs)));
2079 /* Fake up a method call to import */
2080 meth = newSVpvs_share("import");
2081 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2082 op_append_elem(OP_LIST,
2083 op_prepend_elem(OP_LIST, pack, list(arg)),
2084 newSVOP(OP_METHOD_NAMED, 0, meth)));
2085 imop->op_private |= OPpENTERSUB_NOMOD;
2087 /* Combine the ops. */
2088 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2092 =notfor apidoc apply_attrs_string
2094 Attempts to apply a list of attributes specified by the C<attrstr> and
2095 C<len> arguments to the subroutine identified by the C<cv> argument which
2096 is expected to be associated with the package identified by the C<stashpv>
2097 argument (see L<attributes>). It gets this wrong, though, in that it
2098 does not correctly identify the boundaries of the individual attribute
2099 specifications within C<attrstr>. This is not really intended for the
2100 public API, but has to be listed here for systems such as AIX which
2101 need an explicit export list for symbols. (It's called from XS code
2102 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2103 to respect attribute syntax properly would be welcome.
2109 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2110 const char *attrstr, STRLEN len)
2114 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2117 len = strlen(attrstr);
2121 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2123 const char * const sstr = attrstr;
2124 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2125 attrs = op_append_elem(OP_LIST, attrs,
2126 newSVOP(OP_CONST, 0,
2127 newSVpvn(sstr, attrstr-sstr)));
2131 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2132 newSVpvs(ATTRSMODULE),
2133 NULL, op_prepend_elem(OP_LIST,
2134 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2135 op_prepend_elem(OP_LIST,
2136 newSVOP(OP_CONST, 0,
2137 newRV(MUTABLE_SV(cv))),
2142 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2146 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2148 PERL_ARGS_ASSERT_MY_KID;
2150 if (!o || (PL_parser && PL_parser->error_count))
2154 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2155 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2159 if (type == OP_LIST) {
2161 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2162 my_kid(kid, attrs, imopsp);
2163 } else if (type == OP_UNDEF
2169 } else if (type == OP_RV2SV || /* "our" declaration */
2171 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2172 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2173 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2175 PL_parser->in_my == KEY_our
2177 : PL_parser->in_my == KEY_state ? "state" : "my"));
2179 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2180 PL_parser->in_my = FALSE;
2181 PL_parser->in_my_stash = NULL;
2182 apply_attrs(GvSTASH(gv),
2183 (type == OP_RV2SV ? GvSV(gv) :
2184 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2185 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2188 o->op_private |= OPpOUR_INTRO;
2191 else if (type != OP_PADSV &&
2194 type != OP_PUSHMARK)
2196 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2198 PL_parser->in_my == KEY_our
2200 : PL_parser->in_my == KEY_state ? "state" : "my"));
2203 else if (attrs && type != OP_PUSHMARK) {
2206 PL_parser->in_my = FALSE;
2207 PL_parser->in_my_stash = NULL;
2209 /* check for C<my Dog $spot> when deciding package */
2210 stash = PAD_COMPNAME_TYPE(o->op_targ);
2212 stash = PL_curstash;
2213 apply_attrs_my(stash, o, attrs, imopsp);
2215 o->op_flags |= OPf_MOD;
2216 o->op_private |= OPpLVAL_INTRO;
2218 o->op_private |= OPpPAD_STATE;
2223 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2227 int maybe_scalar = 0;
2229 PERL_ARGS_ASSERT_MY_ATTRS;
2231 /* [perl #17376]: this appears to be premature, and results in code such as
2232 C< our(%x); > executing in list mode rather than void mode */
2234 if (o->op_flags & OPf_PARENS)
2244 o = my_kid(o, attrs, &rops);
2246 if (maybe_scalar && o->op_type == OP_PADSV) {
2247 o = scalar(op_append_list(OP_LIST, rops, o));
2248 o->op_private |= OPpLVAL_INTRO;
2251 o = op_append_list(OP_LIST, o, rops);
2253 PL_parser->in_my = FALSE;
2254 PL_parser->in_my_stash = NULL;
2259 Perl_sawparens(pTHX_ OP *o)
2261 PERL_UNUSED_CONTEXT;
2263 o->op_flags |= OPf_PARENS;
2268 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2272 const OPCODE ltype = left->op_type;
2273 const OPCODE rtype = right->op_type;
2275 PERL_ARGS_ASSERT_BIND_MATCH;
2277 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2278 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2280 const char * const desc
2282 rtype == OP_SUBST || rtype == OP_TRANS
2283 || rtype == OP_TRANSR
2285 ? (int)rtype : OP_MATCH];
2286 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2287 ? "@array" : "%hash");
2288 Perl_warner(aTHX_ packWARN(WARN_MISC),
2289 "Applying %s to %s will act on scalar(%s)",
2290 desc, sample, sample);
2293 if (rtype == OP_CONST &&
2294 cSVOPx(right)->op_private & OPpCONST_BARE &&
2295 cSVOPx(right)->op_private & OPpCONST_STRICT)
2297 no_bareword_allowed(right);
2300 /* !~ doesn't make sense with /r, so error on it for now */
2301 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2303 yyerror("Using !~ with s///r doesn't make sense");
2304 if (rtype == OP_TRANSR && type == OP_NOT)
2305 yyerror("Using !~ with tr///r doesn't make sense");
2307 ismatchop = (rtype == OP_MATCH ||
2308 rtype == OP_SUBST ||
2309 rtype == OP_TRANS || rtype == OP_TRANSR)
2310 && !(right->op_flags & OPf_SPECIAL);
2311 if (ismatchop && right->op_private & OPpTARGET_MY) {
2313 right->op_private &= ~OPpTARGET_MY;
2315 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2318 right->op_flags |= OPf_STACKED;
2319 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2320 ! (rtype == OP_TRANS &&
2321 right->op_private & OPpTRANS_IDENTICAL) &&
2322 ! (rtype == OP_SUBST &&
2323 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2324 newleft = op_lvalue(left, rtype);
2327 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2328 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2330 o = op_prepend_elem(rtype, scalar(newleft), right);
2332 return newUNOP(OP_NOT, 0, scalar(o));
2336 return bind_match(type, left,
2337 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2341 Perl_invert(pTHX_ OP *o)
2345 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2349 =for apidoc Amx|OP *|op_scope|OP *o
2351 Wraps up an op tree with some additional ops so that at runtime a dynamic
2352 scope will be created. The original ops run in the new dynamic scope,
2353 and then, provided that they exit normally, the scope will be unwound.
2354 The additional ops used to create and unwind the dynamic scope will
2355 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2356 instead if the ops are simple enough to not need the full dynamic scope
2363 Perl_op_scope(pTHX_ OP *o)
2367 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2368 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2369 o->op_type = OP_LEAVE;
2370 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2372 else if (o->op_type == OP_LINESEQ) {
2374 o->op_type = OP_SCOPE;
2375 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2376 kid = ((LISTOP*)o)->op_first;
2377 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2380 /* The following deals with things like 'do {1 for 1}' */
2381 kid = kid->op_sibling;
2383 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2388 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2394 Perl_block_start(pTHX_ int full)
2397 const int retval = PL_savestack_ix;
2399 pad_block_start(full);
2401 PL_hints &= ~HINT_BLOCK_SCOPE;
2402 SAVECOMPILEWARNINGS();
2403 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2405 CALL_BLOCK_HOOKS(bhk_start, full);
2411 Perl_block_end(pTHX_ I32 floor, OP *seq)
2414 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2415 OP* retval = scalarseq(seq);
2417 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2420 CopHINTS_set(&PL_compiling, PL_hints);
2422 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2425 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2431 =head1 Compile-time scope hooks
2433 =for apidoc Ao||blockhook_register
2435 Register a set of hooks to be called when the Perl lexical scope changes
2436 at compile time. See L<perlguts/"Compile-time scope hooks">.
2442 Perl_blockhook_register(pTHX_ BHK *hk)
2444 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2446 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2453 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2454 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2455 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2458 OP * const o = newOP(OP_PADSV, 0);
2459 o->op_targ = offset;
2465 Perl_newPROG(pTHX_ OP *o)
2469 PERL_ARGS_ASSERT_NEWPROG;
2474 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2475 ((PL_in_eval & EVAL_KEEPERR)
2476 ? OPf_SPECIAL : 0), o);
2477 /* don't use LINKLIST, since PL_eval_root might indirect through
2478 * a rather expensive function call and LINKLIST evaluates its
2479 * argument more than once */
2480 PL_eval_start = op_linklist(PL_eval_root);
2481 PL_eval_root->op_private |= OPpREFCOUNTED;
2482 OpREFCNT_set(PL_eval_root, 1);
2483 PL_eval_root->op_next = 0;
2484 CALL_PEEP(PL_eval_start);
2487 if (o->op_type == OP_STUB) {
2488 PL_comppad_name = 0;
2490 S_op_destroy(aTHX_ o);
2493 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2494 PL_curcop = &PL_compiling;
2495 PL_main_start = LINKLIST(PL_main_root);
2496 PL_main_root->op_private |= OPpREFCOUNTED;
2497 OpREFCNT_set(PL_main_root, 1);
2498 PL_main_root->op_next = 0;
2499 CALL_PEEP(PL_main_start);
2502 /* Register with debugger */
2504 CV * const cv = get_cvs("DB::postponed", 0);
2508 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2510 call_sv(MUTABLE_SV(cv), G_DISCARD);
2517 Perl_localize(pTHX_ OP *o, I32 lex)
2521 PERL_ARGS_ASSERT_LOCALIZE;
2523 if (o->op_flags & OPf_PARENS)
2524 /* [perl #17376]: this appears to be premature, and results in code such as
2525 C< our(%x); > executing in list mode rather than void mode */
2532 if ( PL_parser->bufptr > PL_parser->oldbufptr
2533 && PL_parser->bufptr[-1] == ','
2534 && ckWARN(WARN_PARENTHESIS))
2536 char *s = PL_parser->bufptr;
2539 /* some heuristics to detect a potential error */
2540 while (*s && (strchr(", \t\n", *s)))
2544 if (*s && strchr("@$%*", *s) && *++s
2545 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2548 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2550 while (*s && (strchr(", \t\n", *s)))
2556 if (sigil && (*s == ';' || *s == '=')) {
2557 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2558 "Parentheses missing around \"%s\" list",
2560 ? (PL_parser->in_my == KEY_our
2562 : PL_parser->in_my == KEY_state
2572 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2573 PL_parser->in_my = FALSE;
2574 PL_parser->in_my_stash = NULL;
2579 Perl_jmaybe(pTHX_ OP *o)
2581 PERL_ARGS_ASSERT_JMAYBE;
2583 if (o->op_type == OP_LIST) {
2585 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2586 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2592 S_fold_constants(pTHX_ register OP *o)
2595 register OP * VOL curop;
2597 VOL I32 type = o->op_type;
2602 SV * const oldwarnhook = PL_warnhook;
2603 SV * const olddiehook = PL_diehook;
2607 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2609 if (PL_opargs[type] & OA_RETSCALAR)
2611 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2612 o->op_targ = pad_alloc(type, SVs_PADTMP);
2614 /* integerize op, unless it happens to be C<-foo>.
2615 * XXX should pp_i_negate() do magic string negation instead? */
2616 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2617 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2618 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2620 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2623 if (!(PL_opargs[type] & OA_FOLDCONST))
2628 /* XXX might want a ck_negate() for this */
2629 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2641 /* XXX what about the numeric ops? */
2642 if (PL_hints & HINT_LOCALE)
2647 if (PL_parser && PL_parser->error_count)
2648 goto nope; /* Don't try to run w/ errors */
2650 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2651 const OPCODE type = curop->op_type;
2652 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2654 type != OP_SCALAR &&
2656 type != OP_PUSHMARK)
2662 curop = LINKLIST(o);
2663 old_next = o->op_next;
2667 oldscope = PL_scopestack_ix;
2668 create_eval_scope(G_FAKINGEVAL);
2670 /* Verify that we don't need to save it: */
2671 assert(PL_curcop == &PL_compiling);
2672 StructCopy(&PL_compiling, ¬_compiling, COP);
2673 PL_curcop = ¬_compiling;
2674 /* The above ensures that we run with all the correct hints of the
2675 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2676 assert(IN_PERL_RUNTIME);
2677 PL_warnhook = PERL_WARNHOOK_FATAL;
2684 sv = *(PL_stack_sp--);
2685 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2686 pad_swipe(o->op_targ, FALSE);
2687 else if (SvTEMP(sv)) { /* grab mortal temp? */
2688 SvREFCNT_inc_simple_void(sv);
2693 /* Something tried to die. Abandon constant folding. */
2694 /* Pretend the error never happened. */
2696 o->op_next = old_next;
2700 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2701 PL_warnhook = oldwarnhook;
2702 PL_diehook = olddiehook;
2703 /* XXX note that this croak may fail as we've already blown away
2704 * the stack - eg any nested evals */
2705 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2708 PL_warnhook = oldwarnhook;
2709 PL_diehook = olddiehook;
2710 PL_curcop = &PL_compiling;
2712 if (PL_scopestack_ix > oldscope)
2713 delete_eval_scope();
2722 if (type == OP_RV2GV)
2723 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2725 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2726 op_getmad(o,newop,'f');
2734 S_gen_constant_list(pTHX_ register OP *o)
2738 const I32 oldtmps_floor = PL_tmps_floor;
2741 if (PL_parser && PL_parser->error_count)
2742 return o; /* Don't attempt to run with errors */
2744 PL_op = curop = LINKLIST(o);
2750 assert (!(curop->op_flags & OPf_SPECIAL));
2751 assert(curop->op_type == OP_RANGE);
2753 PL_tmps_floor = oldtmps_floor;
2755 o->op_type = OP_RV2AV;
2756 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2757 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2758 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2759 o->op_opt = 0; /* needs to be revisited in rpeep() */
2760 curop = ((UNOP*)o)->op_first;
2761 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2763 op_getmad(curop,o,'O');
2772 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2775 if (!o || o->op_type != OP_LIST)
2776 o = newLISTOP(OP_LIST, 0, o, NULL);
2778 o->op_flags &= ~OPf_WANT;
2780 if (!(PL_opargs[type] & OA_MARK))
2781 op_null(cLISTOPo->op_first);
2783 o->op_type = (OPCODE)type;
2784 o->op_ppaddr = PL_ppaddr[type];
2785 o->op_flags |= flags;
2787 o = CHECKOP(type, o);
2788 if (o->op_type != (unsigned)type)
2791 return fold_constants(o);
2795 =head1 Optree Manipulation Functions
2798 /* List constructors */
2801 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2803 Append an item to the list of ops contained directly within a list-type
2804 op, returning the lengthened list. I<first> is the list-type op,
2805 and I<last> is the op to append to the list. I<optype> specifies the
2806 intended opcode for the list. If I<first> is not already a list of the
2807 right type, it will be upgraded into one. If either I<first> or I<last>
2808 is null, the other is returned unchanged.
2814 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2822 if (first->op_type != (unsigned)type
2823 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2825 return newLISTOP(type, 0, first, last);
2828 if (first->op_flags & OPf_KIDS)
2829 ((LISTOP*)first)->op_last->op_sibling = last;
2831 first->op_flags |= OPf_KIDS;
2832 ((LISTOP*)first)->op_first = last;
2834 ((LISTOP*)first)->op_last = last;
2839 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2841 Concatenate the lists of ops contained directly within two list-type ops,
2842 returning the combined list. I<first> and I<last> are the list-type ops
2843 to concatenate. I<optype> specifies the intended opcode for the list.
2844 If either I<first> or I<last> is not already a list of the right type,
2845 it will be upgraded into one. If either I<first> or I<last> is null,
2846 the other is returned unchanged.
2852 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2860 if (first->op_type != (unsigned)type)
2861 return op_prepend_elem(type, first, last);
2863 if (last->op_type != (unsigned)type)
2864 return op_append_elem(type, first, last);
2866 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2867 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2868 first->op_flags |= (last->op_flags & OPf_KIDS);
2871 if (((LISTOP*)last)->op_first && first->op_madprop) {
2872 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2874 while (mp->mad_next)
2876 mp->mad_next = first->op_madprop;
2879 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2882 first->op_madprop = last->op_madprop;
2883 last->op_madprop = 0;
2886 S_op_destroy(aTHX_ last);
2892 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2894 Prepend an item to the list of ops contained directly within a list-type
2895 op, returning the lengthened list. I<first> is the op to prepend to the
2896 list, and I<last> is the list-type op. I<optype> specifies the intended
2897 opcode for the list. If I<last> is not already a list of the right type,
2898 it will be upgraded into one. If either I<first> or I<last> is null,
2899 the other is returned unchanged.
2905 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2913 if (last->op_type == (unsigned)type) {
2914 if (type == OP_LIST) { /* already a PUSHMARK there */
2915 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2916 ((LISTOP*)last)->op_first->op_sibling = first;
2917 if (!(first->op_flags & OPf_PARENS))
2918 last->op_flags &= ~OPf_PARENS;
2921 if (!(last->op_flags & OPf_KIDS)) {
2922 ((LISTOP*)last)->op_last = first;
2923 last->op_flags |= OPf_KIDS;
2925 first->op_sibling = ((LISTOP*)last)->op_first;
2926 ((LISTOP*)last)->op_first = first;
2928 last->op_flags |= OPf_KIDS;
2932 return newLISTOP(type, 0, first, last);
2940 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2943 Newxz(tk, 1, TOKEN);
2944 tk->tk_type = (OPCODE)optype;
2945 tk->tk_type = 12345;
2947 tk->tk_mad = madprop;
2952 Perl_token_free(pTHX_ TOKEN* tk)
2954 PERL_ARGS_ASSERT_TOKEN_FREE;
2956 if (tk->tk_type != 12345)
2958 mad_free(tk->tk_mad);
2963 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2968 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2970 if (tk->tk_type != 12345) {
2971 Perl_warner(aTHX_ packWARN(WARN_MISC),
2972 "Invalid TOKEN object ignored");
2979 /* faked up qw list? */
2981 tm->mad_type == MAD_SV &&
2982 SvPVX((SV *)tm->mad_val)[0] == 'q')
2989 /* pretend constant fold didn't happen? */
2990 if (mp->mad_key == 'f' &&
2991 (o->op_type == OP_CONST ||
2992 o->op_type == OP_GV) )
2994 token_getmad(tk,(OP*)mp->mad_val,slot);
3008 if (mp->mad_key == 'X')
3009 mp->mad_key = slot; /* just change the first one */
3019 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3028 /* pretend constant fold didn't happen? */
3029 if (mp->mad_key == 'f' &&
3030 (o->op_type == OP_CONST ||
3031 o->op_type == OP_GV) )
3033 op_getmad(from,(OP*)mp->mad_val,slot);
3040 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3043 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3049 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3058 /* pretend constant fold didn't happen? */
3059 if (mp->mad_key == 'f' &&
3060 (o->op_type == OP_CONST ||
3061 o->op_type == OP_GV) )
3063 op_getmad(from,(OP*)mp->mad_val,slot);
3070 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3073 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3077 PerlIO_printf(PerlIO_stderr(),
3078 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3084 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3102 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3106 addmad(tm, &(o->op_madprop), slot);
3110 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3131 Perl_newMADsv(pTHX_ char key, SV* sv)
3133 PERL_ARGS_ASSERT_NEWMADSV;
3135 return newMADPROP(key, MAD_SV, sv, 0);
3139 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3142 Newxz(mp, 1, MADPROP);
3145 mp->mad_vlen = vlen;
3146 mp->mad_type = type;
3148 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3153 Perl_mad_free(pTHX_ MADPROP* mp)
3155 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3159 mad_free(mp->mad_next);
3160 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3161 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3162 switch (mp->mad_type) {
3166 Safefree((char*)mp->mad_val);
3169 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3170 op_free((OP*)mp->mad_val);
3173 sv_free(MUTABLE_SV(mp->mad_val));
3176 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3185 =head1 Optree construction
3187 =for apidoc Am|OP *|newNULLLIST
3189 Constructs, checks, and returns a new C<stub> op, which represents an
3190 empty list expression.
3196 Perl_newNULLLIST(pTHX)
3198 return newOP(OP_STUB, 0);
3202 S_force_list(pTHX_ OP *o)
3204 if (!o || o->op_type != OP_LIST)
3205 o = newLISTOP(OP_LIST, 0, o, NULL);
3211 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3213 Constructs, checks, and returns an op of any list type. I<type> is
3214 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3215 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3216 supply up to two ops to be direct children of the list op; they are
3217 consumed by this function and become part of the constructed op tree.
3223 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3228 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3230 NewOp(1101, listop, 1, LISTOP);
3232 listop->op_type = (OPCODE)type;
3233 listop->op_ppaddr = PL_ppaddr[type];
3236 listop->op_flags = (U8)flags;
3240 else if (!first && last)
3243 first->op_sibling = last;
3244 listop->op_first = first;
3245 listop->op_last = last;
3246 if (type == OP_LIST) {
3247 OP* const pushop = newOP(OP_PUSHMARK, 0);
3248 pushop->op_sibling = first;
3249 listop->op_first = pushop;
3250 listop->op_flags |= OPf_KIDS;
3252 listop->op_last = pushop;
3255 return CHECKOP(type, listop);
3259 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3261 Constructs, checks, and returns an op of any base type (any type that
3262 has no extra fields). I<type> is the opcode. I<flags> gives the
3263 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3270 Perl_newOP(pTHX_ I32 type, I32 flags)
3275 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3276 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3277 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3278 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3280 NewOp(1101, o, 1, OP);
3281 o->op_type = (OPCODE)type;
3282 o->op_ppaddr = PL_ppaddr[type];
3283 o->op_flags = (U8)flags;
3285 o->op_latefreed = 0;
3289 o->op_private = (U8)(0 | (flags >> 8));
3290 if (PL_opargs[type] & OA_RETSCALAR)
3292 if (PL_opargs[type] & OA_TARGET)
3293 o->op_targ = pad_alloc(type, SVs_PADTMP);
3294 return CHECKOP(type, o);
3298 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3300 Constructs, checks, and returns an op of any unary type. I<type> is
3301 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3302 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3303 bits, the eight bits of C<op_private>, except that the bit with value 1
3304 is automatically set. I<first> supplies an optional op to be the direct
3305 child of the unary op; it is consumed by this function and become part
3306 of the constructed op tree.
3312 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3317 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3318 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3319 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3320 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3321 || type == OP_SASSIGN
3322 || type == OP_ENTERTRY
3323 || type == OP_NULL );
3326 first = newOP(OP_STUB, 0);
3327 if (PL_opargs[type] & OA_MARK)
3328 first = force_list(first);
3330 NewOp(1101, unop, 1, UNOP);
3331 unop->op_type = (OPCODE)type;
3332 unop->op_ppaddr = PL_ppaddr[type];
3333 unop->op_first = first;
3334 unop->op_flags = (U8)(flags | OPf_KIDS);
3335 unop->op_private = (U8)(1 | (flags >> 8));
3336 unop = (UNOP*) CHECKOP(type, unop);
3340 return fold_constants((OP *) unop);
3344 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3346 Constructs, checks, and returns an op of any binary type. I<type>
3347 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3348 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3349 the eight bits of C<op_private>, except that the bit with value 1 or
3350 2 is automatically set as required. I<first> and I<last> supply up to
3351 two ops to be the direct children of the binary op; they are consumed
3352 by this function and become part of the constructed op tree.
3358 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3363 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3364 || type == OP_SASSIGN || type == OP_NULL );
3366 NewOp(1101, binop, 1, BINOP);
3369 first = newOP(OP_NULL, 0);
3371 binop->op_type = (OPCODE)type;
3372 binop->op_ppaddr = PL_ppaddr[type];
3373 binop->op_first = first;
3374 binop->op_flags = (U8)(flags | OPf_KIDS);
3377 binop->op_private = (U8)(1 | (flags >> 8));
3380 binop->op_private = (U8)(2 | (flags >> 8));
3381 first->op_sibling = last;
3384 binop = (BINOP*)CHECKOP(type, binop);
3385 if (binop->op_next || binop->op_type != (OPCODE)type)
3388 binop->op_last = binop->op_first->op_sibling;
3390 return fold_constants((OP *)binop);
3393 static int uvcompare(const void *a, const void *b)
3394 __attribute__nonnull__(1)
3395 __attribute__nonnull__(2)
3396 __attribute__pure__;
3397 static int uvcompare(const void *a, const void *b)
3399 if (*((const UV *)a) < (*(const UV *)b))
3401 if (*((const UV *)a) > (*(const UV *)b))
3403 if (*((const UV *)a+1) < (*(const UV *)b+1))
3405 if (*((const UV *)a+1) > (*(const UV *)b+1))
3411 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3414 SV * const tstr = ((SVOP*)expr)->op_sv;
3417 (repl->op_type == OP_NULL)
3418 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3420 ((SVOP*)repl)->op_sv;
3423 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3424 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3428 register short *tbl;
3430 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3431 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3432 I32 del = o->op_private & OPpTRANS_DELETE;
3435 PERL_ARGS_ASSERT_PMTRANS;
3437 PL_hints |= HINT_BLOCK_SCOPE;
3440 o->op_private |= OPpTRANS_FROM_UTF;
3443 o->op_private |= OPpTRANS_TO_UTF;
3445 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3446 SV* const listsv = newSVpvs("# comment\n");
3448 const U8* tend = t + tlen;
3449 const U8* rend = r + rlen;
3463 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3464 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3467 const U32 flags = UTF8_ALLOW_DEFAULT;
3471 t = tsave = bytes_to_utf8(t, &len);
3474 if (!to_utf && rlen) {
3476 r = rsave = bytes_to_utf8(r, &len);
3480 /* There are several snags with this code on EBCDIC:
3481 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3482 2. scan_const() in toke.c has encoded chars in native encoding which makes
3483 ranges at least in EBCDIC 0..255 range the bottom odd.
3487 U8 tmpbuf[UTF8_MAXBYTES+1];
3490 Newx(cp, 2*tlen, UV);
3492 transv = newSVpvs("");
3494 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3496 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3498 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3502 cp[2*i+1] = cp[2*i];
3506 qsort(cp, i, 2*sizeof(UV), uvcompare);
3507 for (j = 0; j < i; j++) {
3509 diff = val - nextmin;
3511 t = uvuni_to_utf8(tmpbuf,nextmin);
3512 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3514 U8 range_mark = UTF_TO_NATIVE(0xff);
3515 t = uvuni_to_utf8(tmpbuf, val - 1);
3516 sv_catpvn(transv, (char *)&range_mark, 1);
3517 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3524 t = uvuni_to_utf8(tmpbuf,nextmin);
3525 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3527 U8 range_mark = UTF_TO_NATIVE(0xff);
3528 sv_catpvn(transv, (char *)&range_mark, 1);
3530 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3531 UNICODE_ALLOW_SUPER);
3532 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3533 t = (const U8*)SvPVX_const(transv);
3534 tlen = SvCUR(transv);
3538 else if (!rlen && !del) {
3539 r = t; rlen = tlen; rend = tend;
3542 if ((!rlen && !del) || t == r ||
3543 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3545 o->op_private |= OPpTRANS_IDENTICAL;
3549 while (t < tend || tfirst <= tlast) {
3550 /* see if we need more "t" chars */
3551 if (tfirst > tlast) {
3552 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3554 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3556 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3563 /* now see if we need more "r" chars */
3564 if (rfirst > rlast) {
3566 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3568 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3570 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3579 rfirst = rlast = 0xffffffff;
3583 /* now see which range will peter our first, if either. */
3584 tdiff = tlast - tfirst;
3585 rdiff = rlast - rfirst;
3592 if (rfirst == 0xffffffff) {
3593 diff = tdiff; /* oops, pretend rdiff is infinite */
3595 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3596 (long)tfirst, (long)tlast);
3598 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3602 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3603 (long)tfirst, (long)(tfirst + diff),
3606 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3607 (long)tfirst, (long)rfirst);
3609 if (rfirst + diff > max)
3610 max = rfirst + diff;
3612 grows = (tfirst < rfirst &&
3613 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3625 else if (max > 0xff)
3630 PerlMemShared_free(cPVOPo->op_pv);
3631 cPVOPo->op_pv = NULL;
3633 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3635 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3636 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3637 PAD_SETSV(cPADOPo->op_padix, swash);
3639 SvREADONLY_on(swash);
3641 cSVOPo->op_sv = swash;
3643 SvREFCNT_dec(listsv);
3644 SvREFCNT_dec(transv);
3646 if (!del && havefinal && rlen)
3647 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3648 newSVuv((UV)final), 0);
3651 o->op_private |= OPpTRANS_GROWS;
3657 op_getmad(expr,o,'e');
3658 op_getmad(repl,o,'r');
3666 tbl = (short*)cPVOPo->op_pv;
3668 Zero(tbl, 256, short);
3669 for (i = 0; i < (I32)tlen; i++)
3671 for (i = 0, j = 0; i < 256; i++) {
3673 if (j >= (I32)rlen) {
3682 if (i < 128 && r[j] >= 128)
3692 o->op_private |= OPpTRANS_IDENTICAL;
3694 else if (j >= (I32)rlen)
3699 PerlMemShared_realloc(tbl,
3700 (0x101+rlen-j) * sizeof(short));
3701 cPVOPo->op_pv = (char*)tbl;
3703 tbl[0x100] = (short)(rlen - j);
3704 for (i=0; i < (I32)rlen - j; i++)
3705 tbl[0x101+i] = r[j+i];
3709 if (!rlen && !del) {
3712 o->op_private |= OPpTRANS_IDENTICAL;
3714 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3715 o->op_private |= OPpTRANS_IDENTICAL;
3717 for (i = 0; i < 256; i++)
3719 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3720 if (j >= (I32)rlen) {
3722 if (tbl[t[i]] == -1)
3728 if (tbl[t[i]] == -1) {
3729 if (t[i] < 128 && r[j] >= 128)
3736 if(del && rlen == tlen) {
3737 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3738 } else if(rlen > tlen) {
3739 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3743 o->op_private |= OPpTRANS_GROWS;
3745 op_getmad(expr,o,'e');
3746 op_getmad(repl,o,'r');
3756 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3758 Constructs, checks, and returns an op of any pattern matching type.
3759 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3760 and, shifted up eight bits, the eight bits of C<op_private>.
3766 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3771 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3773 NewOp(1101, pmop, 1, PMOP);
3774 pmop->op_type = (OPCODE)type;
3775 pmop->op_ppaddr = PL_ppaddr[type];
3776 pmop->op_flags = (U8)flags;
3777 pmop->op_private = (U8)(0 | (flags >> 8));
3779 if (PL_hints & HINT_RE_TAINT)
3780 pmop->op_pmflags |= PMf_RETAINT;
3781 if (PL_hints & HINT_LOCALE) {
3782 pmop->op_pmflags |= PMf_LOCALE;
3784 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3785 pmop->op_pmflags |= RXf_PMf_UNICODE;
3787 if (PL_hints & HINT_RE_FLAGS) {
3788 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3789 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3791 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3792 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3793 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3795 if (reflags && SvOK(reflags)) {
3796 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3797 pmop->op_pmflags |= SvIV(reflags);
3803 assert(SvPOK(PL_regex_pad[0]));
3804 if (SvCUR(PL_regex_pad[0])) {
3805 /* Pop off the "packed" IV from the end. */
3806 SV *const repointer_list = PL_regex_pad[0];
3807 const char *p = SvEND(repointer_list) - sizeof(IV);
3808 const IV offset = *((IV*)p);
3810 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3812 SvEND_set(repointer_list, p);
3814 pmop->op_pmoffset = offset;
3815 /* This slot should be free, so assert this: */
3816 assert(PL_regex_pad[offset] == &PL_sv_undef);
3818 SV * const repointer = &PL_sv_undef;
3819 av_push(PL_regex_padav, repointer);
3820 pmop->op_pmoffset = av_len(PL_regex_padav);
3821 PL_regex_pad = AvARRAY(PL_regex_padav);
3825 return CHECKOP(type, pmop);
3828 /* Given some sort of match op o, and an expression expr containing a
3829 * pattern, either compile expr into a regex and attach it to o (if it's
3830 * constant), or convert expr into a runtime regcomp op sequence (if it's
3833 * isreg indicates that the pattern is part of a regex construct, eg
3834 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3835 * split "pattern", which aren't. In the former case, expr will be a list
3836 * if the pattern contains more than one term (eg /a$b/) or if it contains
3837 * a replacement, ie s/// or tr///.
3841 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3846 I32 repl_has_vars = 0;
3850 PERL_ARGS_ASSERT_PMRUNTIME;
3853 o->op_type == OP_SUBST
3854 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3856 /* last element in list is the replacement; pop it */
3858 repl = cLISTOPx(expr)->op_last;
3859 kid = cLISTOPx(expr)->op_first;
3860 while (kid->op_sibling != repl)
3861 kid = kid->op_sibling;
3862 kid->op_sibling = NULL;
3863 cLISTOPx(expr)->op_last = kid;
3866 if (isreg && expr->op_type == OP_LIST &&
3867 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3869 /* convert single element list to element */
3870 OP* const oe = expr;
3871 expr = cLISTOPx(oe)->op_first->op_sibling;
3872 cLISTOPx(oe)->op_first->op_sibling = NULL;
3873 cLISTOPx(oe)->op_last = NULL;
3877 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3878 return pmtrans(o, expr, repl);
3881 reglist = isreg && expr->op_type == OP_LIST;
3885 PL_hints |= HINT_BLOCK_SCOPE;
3888 if (expr->op_type == OP_CONST) {
3889 SV *pat = ((SVOP*)expr)->op_sv;
3890 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3892 if (o->op_flags & OPf_SPECIAL)
3893 pm_flags |= RXf_SPLIT;
3896 assert (SvUTF8(pat));
3897 } else if (SvUTF8(pat)) {
3898 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3899 trapped in use 'bytes'? */
3900 /* Make a copy of the octet sequence, but without the flag on, as
3901 the compiler now honours the SvUTF8 flag on pat. */
3903 const char *const p = SvPV(pat, len);
3904 pat = newSVpvn_flags(p, len, SVs_TEMP);
3907 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3910 op_getmad(expr,(OP*)pm,'e');
3916 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3917 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3919 : OP_REGCMAYBE),0,expr);
3921 NewOp(1101, rcop, 1, LOGOP);
3922 rcop->op_type = OP_REGCOMP;
3923 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3924 rcop->op_first = scalar(expr);
3925 rcop->op_flags |= OPf_KIDS
3926 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3927 | (reglist ? OPf_STACKED : 0);
3928 rcop->op_private = 1;
3931 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3933 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3934 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
3936 /* establish postfix order */
3937 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3939 rcop->op_next = expr;
3940 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3943 rcop->op_next = LINKLIST(expr);
3944 expr->op_next = (OP*)rcop;
3947 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3952 if (pm->op_pmflags & PMf_EVAL) {
3954 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3955 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3957 else if (repl->op_type == OP_CONST)
3961 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3962 if (curop->op_type == OP_SCOPE
3963 || curop->op_type == OP_LEAVE
3964 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3965 if (curop->op_type == OP_GV) {
3966 GV * const gv = cGVOPx_gv(curop);
3968 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3971 else if (curop->op_type == OP_RV2CV)
3973 else if (curop->op_type == OP_RV2SV ||
3974 curop->op_type == OP_RV2AV ||
3975 curop->op_type == OP_RV2HV ||
3976 curop->op_type == OP_RV2GV) {
3977 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3980 else if (curop->op_type == OP_PADSV ||
3981 curop->op_type == OP_PADAV ||
3982 curop->op_type == OP_PADHV ||
3983 curop->op_type == OP_PADANY)
3987 else if (curop->op_type == OP_PUSHRE)
3988 NOOP; /* Okay here, dangerous in newASSIGNOP */
3998 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4000 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4001 op_prepend_elem(o->op_type, scalar(repl), o);
4004 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4005 pm->op_pmflags |= PMf_MAYBE_CONST;
4007 NewOp(1101, rcop, 1, LOGOP);
4008 rcop->op_type = OP_SUBSTCONT;
4009 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4010 rcop->op_first = scalar(repl);
4011 rcop->op_flags |= OPf_KIDS;
4012 rcop->op_private = 1;
4015 /* establish postfix order */
4016 rcop->op_next = LINKLIST(repl);
4017 repl->op_next = (OP*)rcop;
4019 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4020 assert(!(pm->op_pmflags & PMf_ONCE));
4021 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4030 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4032 Constructs, checks, and returns an op of any type that involves an
4033 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4034 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4035 takes ownership of one reference to it.
4041 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4046 PERL_ARGS_ASSERT_NEWSVOP;
4048 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4049 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4050 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4052 NewOp(1101, svop, 1, SVOP);
4053 svop->op_type = (OPCODE)type;
4054 svop->op_ppaddr = PL_ppaddr[type];
4056 svop->op_next = (OP*)svop;
4057 svop->op_flags = (U8)flags;
4058 if (PL_opargs[type] & OA_RETSCALAR)
4060 if (PL_opargs[type] & OA_TARGET)
4061 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4062 return CHECKOP(type, svop);
4068 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4070 Constructs, checks, and returns an op of any type that involves a
4071 reference to a pad element. I<type> is the opcode. I<flags> gives the
4072 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4073 is populated with I<sv>; this function takes ownership of one reference
4076 This function only exists if Perl has been compiled to use ithreads.
4082 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4087 PERL_ARGS_ASSERT_NEWPADOP;
4089 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4090 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4091 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4093 NewOp(1101, padop, 1, PADOP);
4094 padop->op_type = (OPCODE)type;
4095 padop->op_ppaddr = PL_ppaddr[type];
4096 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4097 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4098 PAD_SETSV(padop->op_padix, sv);
4101 padop->op_next = (OP*)padop;
4102 padop->op_flags = (U8)flags;
4103 if (PL_opargs[type] & OA_RETSCALAR)
4105 if (PL_opargs[type] & OA_TARGET)
4106 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4107 return CHECKOP(type, padop);
4110 #endif /* !USE_ITHREADS */
4113 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4115 Constructs, checks, and returns an op of any type that involves an
4116 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4117 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4118 reference; calling this function does not transfer ownership of any
4125 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4129 PERL_ARGS_ASSERT_NEWGVOP;
4133 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4135 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4140 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4142 Constructs, checks, and returns an op of any type that involves an
4143 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4144 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4145 must have been allocated using L</PerlMemShared_malloc>; the memory will
4146 be freed when the op is destroyed.
4152 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4157 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4158 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4160 NewOp(1101, pvop, 1, PVOP);
4161 pvop->op_type = (OPCODE)type;
4162 pvop->op_ppaddr = PL_ppaddr[type];
4164 pvop->op_next = (OP*)pvop;
4165 pvop->op_flags = (U8)flags;
4166 if (PL_opargs[type] & OA_RETSCALAR)
4168 if (PL_opargs[type] & OA_TARGET)
4169 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4170 return CHECKOP(type, pvop);
4178 Perl_package(pTHX_ OP *o)
4181 SV *const sv = cSVOPo->op_sv;
4186 PERL_ARGS_ASSERT_PACKAGE;
4188 save_hptr(&PL_curstash);
4189 save_item(PL_curstname);
4191 PL_curstash = gv_stashsv(sv, GV_ADD);
4193 sv_setsv(PL_curstname, sv);
4195 PL_hints |= HINT_BLOCK_SCOPE;
4196 PL_parser->copline = NOLINE;
4197 PL_parser->expect = XSTATE;
4202 if (!PL_madskills) {
4207 pegop = newOP(OP_NULL,0);
4208 op_getmad(o,pegop,'P');
4214 Perl_package_version( pTHX_ OP *v )
4217 U32 savehints = PL_hints;
4218 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4219 PL_hints &= ~HINT_STRICT_VARS;
4220 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4221 PL_hints = savehints;
4230 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4237 OP *pegop = newOP(OP_NULL,0);
4239 SV *use_version = NULL;
4241 PERL_ARGS_ASSERT_UTILIZE;
4243 if (idop->op_type != OP_CONST)
4244 Perl_croak(aTHX_ "Module name must be constant");
4247 op_getmad(idop,pegop,'U');
4252 SV * const vesv = ((SVOP*)version)->op_sv;
4255 op_getmad(version,pegop,'V');
4256 if (!arg && !SvNIOKp(vesv)) {
4263 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4264 Perl_croak(aTHX_ "Version number must be a constant number");
4266 /* Make copy of idop so we don't free it twice */
4267 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4269 /* Fake up a method call to VERSION */
4270 meth = newSVpvs_share("VERSION");
4271 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4272 op_append_elem(OP_LIST,
4273 op_prepend_elem(OP_LIST, pack, list(version)),
4274 newSVOP(OP_METHOD_NAMED, 0, meth)));
4278 /* Fake up an import/unimport */
4279 if (arg && arg->op_type == OP_STUB) {
4281 op_getmad(arg,pegop,'S');
4282 imop = arg; /* no import on explicit () */
4284 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4285 imop = NULL; /* use 5.0; */
4287 use_version = ((SVOP*)idop)->op_sv;
4289 idop->op_private |= OPpCONST_NOVER;
4295 op_getmad(arg,pegop,'A');
4297 /* Make copy of idop so we don't free it twice */
4298 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4300 /* Fake up a method call to import/unimport */
4302 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4304 op_append_elem(OP_LIST,
4305 op_prepend_elem(OP_LIST, pack, list(arg)),
4306 newSVOP(OP_METHOD_NAMED, 0, meth)));
4309 /* Fake up the BEGIN {}, which does its thing immediately. */
4311 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4314 op_append_elem(OP_LINESEQ,
4315 op_append_elem(OP_LINESEQ,
4316 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4317 newSTATEOP(0, NULL, veop)),
4318 newSTATEOP(0, NULL, imop) ));
4321 /* If we request a version >= 5.9.5, load feature.pm with the
4322 * feature bundle that corresponds to the required version. */
4323 use_version = sv_2mortal(new_version(use_version));
4325 if (vcmp(use_version,
4326 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4327 SV *const importsv = vnormal(use_version);
4328 *SvPVX_mutable(importsv) = ':';
4329 ENTER_with_name("load_feature");
4330 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4331 LEAVE_with_name("load_feature");
4333 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4334 if (vcmp(use_version,
4335 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4336 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4340 /* The "did you use incorrect case?" warning used to be here.
4341 * The problem is that on case-insensitive filesystems one
4342 * might get false positives for "use" (and "require"):
4343 * "use Strict" or "require CARP" will work. This causes
4344 * portability problems for the script: in case-strict
4345 * filesystems the script will stop working.
4347 * The "incorrect case" warning checked whether "use Foo"
4348 * imported "Foo" to your namespace, but that is wrong, too:
4349 * there is no requirement nor promise in the language that
4350 * a Foo.pm should or would contain anything in package "Foo".
4352 * There is very little Configure-wise that can be done, either:
4353 * the case-sensitivity of the build filesystem of Perl does not
4354 * help in guessing the case-sensitivity of the runtime environment.
4357 PL_hints |= HINT_BLOCK_SCOPE;
4358 PL_parser->copline = NOLINE;
4359 PL_parser->expect = XSTATE;
4360 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4363 if (!PL_madskills) {
4364 /* FIXME - don't allocate pegop if !PL_madskills */
4373 =head1 Embedding Functions
4375 =for apidoc load_module
4377 Loads the module whose name is pointed to by the string part of name.
4378 Note that the actual module name, not its filename, should be given.
4379 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4380 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4381 (or 0 for no flags). ver, if specified, provides version semantics
4382 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4383 arguments can be used to specify arguments to the module's import()
4384 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4385 terminated with a final NULL pointer. Note that this list can only
4386 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4387 Otherwise at least a single NULL pointer to designate the default
4388 import list is required.
4393 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4397 PERL_ARGS_ASSERT_LOAD_MODULE;
4399 va_start(args, ver);
4400 vload_module(flags, name, ver, &args);
4404 #ifdef PERL_IMPLICIT_CONTEXT
4406 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4410 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4411 va_start(args, ver);
4412 vload_module(flags, name, ver, &args);
4418 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4422 OP * const modname = newSVOP(OP_CONST, 0, name);
4424 PERL_ARGS_ASSERT_VLOAD_MODULE;
4426 modname->op_private |= OPpCONST_BARE;
4428 veop = newSVOP(OP_CONST, 0, ver);
4432 if (flags & PERL_LOADMOD_NOIMPORT) {
4433 imop = sawparens(newNULLLIST());
4435 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4436 imop = va_arg(*args, OP*);
4441 sv = va_arg(*args, SV*);
4443 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4444 sv = va_arg(*args, SV*);
4448 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4449 * that it has a PL_parser to play with while doing that, and also
4450 * that it doesn't mess with any existing parser, by creating a tmp
4451 * new parser with lex_start(). This won't actually be used for much,
4452 * since pp_require() will create another parser for the real work. */
4455 SAVEVPTR(PL_curcop);
4456 lex_start(NULL, NULL, 0);
4457 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4458 veop, modname, imop);
4463 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4469 PERL_ARGS_ASSERT_DOFILE;
4471 if (!force_builtin) {
4472 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4473 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4474 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4475 gv = gvp ? *gvp : NULL;
4479 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4480 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4481 op_append_elem(OP_LIST, term,
4482 scalar(newUNOP(OP_RV2CV, 0,
4483 newGVOP(OP_GV, 0, gv))))));
4486 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4492 =head1 Optree construction
4494 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4496 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4497 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4498 be set automatically, and, shifted up eight bits, the eight bits of
4499 C<op_private>, except that the bit with value 1 or 2 is automatically
4500 set as required. I<listval> and I<subscript> supply the parameters of
4501 the slice; they are consumed by this function and become part of the
4502 constructed op tree.
4508 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4510 return newBINOP(OP_LSLICE, flags,
4511 list(force_list(subscript)),
4512 list(force_list(listval)) );
4516 S_is_list_assignment(pTHX_ register const OP *o)
4524 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4525 o = cUNOPo->op_first;
4527 flags = o->op_flags;
4529 if (type == OP_COND_EXPR) {
4530 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4531 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4536 yyerror("Assignment to both a list and a scalar");
4540 if (type == OP_LIST &&
4541 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4542 o->op_private & OPpLVAL_INTRO)
4545 if (type == OP_LIST || flags & OPf_PARENS ||
4546 type == OP_RV2AV || type == OP_RV2HV ||
4547 type == OP_ASLICE || type == OP_HSLICE)
4550 if (type == OP_PADAV || type == OP_PADHV)
4553 if (type == OP_RV2SV)
4560 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4562 Constructs, checks, and returns an assignment op. I<left> and I<right>
4563 supply the parameters of the assignment; they are consumed by this
4564 function and become part of the constructed op tree.
4566 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4567 a suitable conditional optree is constructed. If I<optype> is the opcode
4568 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4569 performs the binary operation and assigns the result to the left argument.
4570 Either way, if I<optype> is non-zero then I<flags> has no effect.
4572 If I<optype> is zero, then a plain scalar or list assignment is
4573 constructed. Which type of assignment it is is automatically determined.
4574 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4575 will be set automatically, and, shifted up eight bits, the eight bits
4576 of C<op_private>, except that the bit with value 1 or 2 is automatically
4583 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4589 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4590 return newLOGOP(optype, 0,
4591 op_lvalue(scalar(left), optype),
4592 newUNOP(OP_SASSIGN, 0, scalar(right)));
4595 return newBINOP(optype, OPf_STACKED,
4596 op_lvalue(scalar(left), optype), scalar(right));
4600 if (is_list_assignment(left)) {
4601 static const char no_list_state[] = "Initialization of state variables"
4602 " in list context currently forbidden";
4604 bool maybe_common_vars = TRUE;
4607 /* Grandfathering $[ assignment here. Bletch.*/
4608 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4609 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4610 left = op_lvalue(left, OP_AASSIGN);
4613 else if (left->op_type == OP_CONST) {
4614 deprecate("assignment to $[");
4616 /* Result of assignment is always 1 (or we'd be dead already) */
4617 return newSVOP(OP_CONST, 0, newSViv(1));
4619 curop = list(force_list(left));
4620 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4621 o->op_private = (U8)(0 | (flags >> 8));
4623 if ((left->op_type == OP_LIST
4624 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4626 OP* lop = ((LISTOP*)left)->op_first;
4627 maybe_common_vars = FALSE;
4629 if (lop->op_type == OP_PADSV ||
4630 lop->op_type == OP_PADAV ||
4631 lop->op_type == OP_PADHV ||
4632 lop->op_type == OP_PADANY) {
4633 if (!(lop->op_private & OPpLVAL_INTRO))
4634 maybe_common_vars = TRUE;
4636 if (lop->op_private & OPpPAD_STATE) {
4637 if (left->op_private & OPpLVAL_INTRO) {
4638 /* Each variable in state($a, $b, $c) = ... */
4641 /* Each state variable in
4642 (state $a, my $b, our $c, $d, undef) = ... */
4644 yyerror(no_list_state);
4646 /* Each my variable in
4647 (state $a, my $b, our $c, $d, undef) = ... */
4649 } else if (lop->op_type == OP_UNDEF ||
4650 lop->op_type == OP_PUSHMARK) {
4651 /* undef may be interesting in
4652 (state $a, undef, state $c) */
4654 /* Other ops in the list. */
4655 maybe_common_vars = TRUE;
4657 lop = lop->op_sibling;
4660 else if ((left->op_private & OPpLVAL_INTRO)
4661 && ( left->op_type == OP_PADSV
4662 || left->op_type == OP_PADAV
4663 || left->op_type == OP_PADHV
4664 || left->op_type == OP_PADANY))
4666 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4667 if (left->op_private & OPpPAD_STATE) {
4668 /* All single variable list context state assignments, hence
4678 yyerror(no_list_state);
4682 /* PL_generation sorcery:
4683 * an assignment like ($a,$b) = ($c,$d) is easier than
4684 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4685 * To detect whether there are common vars, the global var
4686 * PL_generation is incremented for each assign op we compile.
4687 * Then, while compiling the assign op, we run through all the
4688 * variables on both sides of the assignment, setting a spare slot
4689 * in each of them to PL_generation. If any of them already have
4690 * that value, we know we've got commonality. We could use a
4691 * single bit marker, but then we'd have to make 2 passes, first
4692 * to clear the flag, then to test and set it. To find somewhere
4693 * to store these values, evil chicanery is done with SvUVX().
4696 if (maybe_common_vars) {
4699 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4700 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4701 if (curop->op_type == OP_GV) {
4702 GV *gv = cGVOPx_gv(curop);
4704 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4706 GvASSIGN_GENERATION_set(gv, PL_generation);
4708 else if (curop->op_type == OP_PADSV ||
4709 curop->op_type == OP_PADAV ||
4710 curop->op_type == OP_PADHV ||
4711 curop->op_type == OP_PADANY)
4713 if (PAD_COMPNAME_GEN(curop->op_targ)
4714 == (STRLEN)PL_generation)
4716 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4719 else if (curop->op_type == OP_RV2CV)
4721 else if (curop->op_type == OP_RV2SV ||
4722 curop->op_type == OP_RV2AV ||
4723 curop->op_type == OP_RV2HV ||
4724 curop->op_type == OP_RV2GV) {
4725 if (lastop->op_type != OP_GV) /* funny deref? */
4728 else if (curop->op_type == OP_PUSHRE) {
4730 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4731 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4733 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4735 GvASSIGN_GENERATION_set(gv, PL_generation);
4739 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4742 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4744 GvASSIGN_GENERATION_set(gv, PL_generation);
4754 o->op_private |= OPpASSIGN_COMMON;
4757 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4758 OP* tmpop = ((LISTOP*)right)->op_first;
4759 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4760 PMOP * const pm = (PMOP*)tmpop;
4761 if (left->op_type == OP_RV2AV &&
4762 !(left->op_private & OPpLVAL_INTRO) &&
4763 !(o->op_private & OPpASSIGN_COMMON) )
4765 tmpop = ((UNOP*)left)->op_first;
4766 if (tmpop->op_type == OP_GV
4768 && !pm->op_pmreplrootu.op_pmtargetoff
4770 && !pm->op_pmreplrootu.op_pmtargetgv
4774 pm->op_pmreplrootu.op_pmtargetoff
4775 = cPADOPx(tmpop)->op_padix;
4776 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4778 pm->op_pmreplrootu.op_pmtargetgv
4779 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4780 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4782 pm->op_pmflags |= PMf_ONCE;
4783 tmpop = cUNOPo->op_first; /* to list (nulled) */
4784 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4785 tmpop->op_sibling = NULL; /* don't free split */
4786 right->op_next = tmpop->op_next; /* fix starting loc */
4787 op_free(o); /* blow off assign */
4788 right->op_flags &= ~OPf_WANT;
4789 /* "I don't know and I don't care." */
4794 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4795 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4797 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4798 if (SvIOK(sv) && SvIVX(sv) == 0)
4799 sv_setiv(sv, PL_modcount+1);
4807 right = newOP(OP_UNDEF, 0);
4808 if (right->op_type == OP_READLINE) {
4809 right->op_flags |= OPf_STACKED;
4810 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4814 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4815 o = newBINOP(OP_SASSIGN, flags,
4816 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4820 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4821 deprecate("assignment to $[");
4823 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4824 o->op_private |= OPpCONST_ARYBASE;
4832 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4834 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4835 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4836 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4837 If I<label> is non-null, it supplies the name of a label to attach to
4838 the state op; this function takes ownership of the memory pointed at by
4839 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4842 If I<o> is null, the state op is returned. Otherwise the state op is
4843 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4844 is consumed by this function and becomes part of the returned op tree.
4850 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4853 const U32 seq = intro_my();
4856 NewOp(1101, cop, 1, COP);
4857 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4858 cop->op_type = OP_DBSTATE;
4859 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4862 cop->op_type = OP_NEXTSTATE;
4863 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4865 cop->op_flags = (U8)flags;
4866 CopHINTS_set(cop, PL_hints);
4868 cop->op_private |= NATIVE_HINTS;
4870 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4871 cop->op_next = (OP*)cop;
4874 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4875 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4877 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4878 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4880 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4882 PL_hints |= HINT_BLOCK_SCOPE;
4883 /* It seems that we need to defer freeing this pointer, as other parts
4884 of the grammar end up wanting to copy it after this op has been
4889 if (PL_parser && PL_parser->copline == NOLINE)
4890 CopLINE_set(cop, CopLINE(PL_curcop));
4892 CopLINE_set(cop, PL_parser->copline);
4894 PL_parser->copline = NOLINE;
4897 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4899 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4901 CopSTASH_set(cop, PL_curstash);
4903 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4904 /* this line can have a breakpoint - store the cop in IV */
4905 AV *av = CopFILEAVx(PL_curcop);
4907 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4908 if (svp && *svp != &PL_sv_undef ) {
4909 (void)SvIOK_on(*svp);
4910 SvIV_set(*svp, PTR2IV(cop));
4915 if (flags & OPf_SPECIAL)
4917 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4921 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4923 Constructs, checks, and returns a logical (flow control) op. I<type>
4924 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4925 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4926 the eight bits of C<op_private>, except that the bit with value 1 is
4927 automatically set. I<first> supplies the expression controlling the
4928 flow, and I<other> supplies the side (alternate) chain of ops; they are
4929 consumed by this function and become part of the constructed op tree.
4935 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4939 PERL_ARGS_ASSERT_NEWLOGOP;
4941 return new_logop(type, flags, &first, &other);
4945 S_search_const(pTHX_ OP *o)
4947 PERL_ARGS_ASSERT_SEARCH_CONST;
4949 switch (o->op_type) {
4953 if (o->op_flags & OPf_KIDS)
4954 return search_const(cUNOPo->op_first);
4961 if (!(o->op_flags & OPf_KIDS))
4963 kid = cLISTOPo->op_first;
4965 switch (kid->op_type) {
4969 kid = kid->op_sibling;
4972 if (kid != cLISTOPo->op_last)
4978 kid = cLISTOPo->op_last;
4980 return search_const(kid);
4988 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4996 int prepend_not = 0;
4998 PERL_ARGS_ASSERT_NEW_LOGOP;
5003 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5004 return newBINOP(type, flags, scalar(first), scalar(other));
5006 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5008 scalarboolean(first);
5009 /* optimize AND and OR ops that have NOTs as children */
5010 if (first->op_type == OP_NOT
5011 && (first->op_flags & OPf_KIDS)
5012 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5013 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5015 if (type == OP_AND || type == OP_OR) {
5021 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5023 prepend_not = 1; /* prepend a NOT op later */
5027 /* search for a constant op that could let us fold the test */
5028 if ((cstop = search_const(first))) {
5029 if (cstop->op_private & OPpCONST_STRICT)
5030 no_bareword_allowed(cstop);
5031 else if ((cstop->op_private & OPpCONST_BARE))
5032 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5033 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5034 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5035 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5037 if (other->op_type == OP_CONST)
5038 other->op_private |= OPpCONST_SHORTCIRCUIT;
5040 OP *newop = newUNOP(OP_NULL, 0, other);
5041 op_getmad(first, newop, '1');
5042 newop->op_targ = type; /* set "was" field */
5046 if (other->op_type == OP_LEAVE)
5047 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5048 else if (other->op_type == OP_MATCH
5049 || other->op_type == OP_SUBST
5050 || other->op_type == OP_TRANSR
5051 || other->op_type == OP_TRANS)
5052 /* Mark the op as being unbindable with =~ */
5053 other->op_flags |= OPf_SPECIAL;
5057 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5058 const OP *o2 = other;
5059 if ( ! (o2->op_type == OP_LIST
5060 && (( o2 = cUNOPx(o2)->op_first))
5061 && o2->op_type == OP_PUSHMARK
5062 && (( o2 = o2->op_sibling)) )
5065 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5066 || o2->op_type == OP_PADHV)
5067 && o2->op_private & OPpLVAL_INTRO
5068 && !(o2->op_private & OPpPAD_STATE))
5070 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5071 "Deprecated use of my() in false conditional");
5075 if (first->op_type == OP_CONST)
5076 first->op_private |= OPpCONST_SHORTCIRCUIT;
5078 first = newUNOP(OP_NULL, 0, first);
5079 op_getmad(other, first, '2');
5080 first->op_targ = type; /* set "was" field */
5087 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5088 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5090 const OP * const k1 = ((UNOP*)first)->op_first;
5091 const OP * const k2 = k1->op_sibling;
5093 switch (first->op_type)
5096 if (k2 && k2->op_type == OP_READLINE
5097 && (k2->op_flags & OPf_STACKED)
5098 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5100 warnop = k2->op_type;
5105 if (k1->op_type == OP_READDIR
5106 || k1->op_type == OP_GLOB
5107 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5108 || k1->op_type == OP_EACH)
5110 warnop = ((k1->op_type == OP_NULL)
5111 ? (OPCODE)k1->op_targ : k1->op_type);
5116 const line_t oldline = CopLINE(PL_curcop);
5117 CopLINE_set(PL_curcop, PL_parser->copline);
5118 Perl_warner(aTHX_ packWARN(WARN_MISC),
5119 "Value of %s%s can be \"0\"; test with defined()",
5121 ((warnop == OP_READLINE || warnop == OP_GLOB)
5122 ? " construct" : "() operator"));
5123 CopLINE_set(PL_curcop, oldline);
5130 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5131 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5133 NewOp(1101, logop, 1, LOGOP);
5135 logop->op_type = (OPCODE)type;
5136 logop->op_ppaddr = PL_ppaddr[type];
5137 logop->op_first = first;
5138 logop->op_flags = (U8)(flags | OPf_KIDS);
5139 logop->op_other = LINKLIST(other);
5140 logop->op_private = (U8)(1 | (flags >> 8));
5142 /* establish postfix order */
5143 logop->op_next = LINKLIST(first);
5144 first->op_next = (OP*)logop;
5145 first->op_sibling = other;
5147 CHECKOP(type,logop);
5149 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5156 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5158 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5159 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5160 will be set automatically, and, shifted up eight bits, the eight bits of
5161 C<op_private>, except that the bit with value 1 is automatically set.
5162 I<first> supplies the expression selecting between the two branches,
5163 and I<trueop> and I<falseop> supply the branches; they are consumed by
5164 this function and become part of the constructed op tree.
5170 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5178 PERL_ARGS_ASSERT_NEWCONDOP;
5181 return newLOGOP(OP_AND, 0, first, trueop);
5183 return newLOGOP(OP_OR, 0, first, falseop);
5185 scalarboolean(first);
5186 if ((cstop = search_const(first))) {
5187 /* Left or right arm of the conditional? */
5188 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5189 OP *live = left ? trueop : falseop;
5190 OP *const dead = left ? falseop : trueop;
5191 if (cstop->op_private & OPpCONST_BARE &&
5192 cstop->op_private & OPpCONST_STRICT) {
5193 no_bareword_allowed(cstop);
5196 /* This is all dead code when PERL_MAD is not defined. */
5197 live = newUNOP(OP_NULL, 0, live);
5198 op_getmad(first, live, 'C');
5199 op_getmad(dead, live, left ? 'e' : 't');
5204 if (live->op_type == OP_LEAVE)
5205 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5206 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5207 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5208 /* Mark the op as being unbindable with =~ */
5209 live->op_flags |= OPf_SPECIAL;
5212 NewOp(1101, logop, 1, LOGOP);
5213 logop->op_type = OP_COND_EXPR;
5214 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5215 logop->op_first = first;
5216 logop->op_flags = (U8)(flags | OPf_KIDS);
5217 logop->op_private = (U8)(1 | (flags >> 8));
5218 logop->op_other = LINKLIST(trueop);
5219 logop->op_next = LINKLIST(falseop);
5221 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5224 /* establish postfix order */
5225 start = LINKLIST(first);
5226 first->op_next = (OP*)logop;
5228 first->op_sibling = trueop;
5229 trueop->op_sibling = falseop;
5230 o = newUNOP(OP_NULL, 0, (OP*)logop);
5232 trueop->op_next = falseop->op_next = o;
5239 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5241 Constructs and returns a C<range> op, with subordinate C<flip> and
5242 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5243 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5244 for both the C<flip> and C<range> ops, except that the bit with value
5245 1 is automatically set. I<left> and I<right> supply the expressions
5246 controlling the endpoints of the range; they are consumed by this function
5247 and become part of the constructed op tree.
5253 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5262 PERL_ARGS_ASSERT_NEWRANGE;
5264 NewOp(1101, range, 1, LOGOP);
5266 range->op_type = OP_RANGE;
5267 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5268 range->op_first = left;
5269 range->op_flags = OPf_KIDS;
5270 leftstart = LINKLIST(left);
5271 range->op_other = LINKLIST(right);
5272 range->op_private = (U8)(1 | (flags >> 8));
5274 left->op_sibling = right;
5276 range->op_next = (OP*)range;
5277 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5278 flop = newUNOP(OP_FLOP, 0, flip);
5279 o = newUNOP(OP_NULL, 0, flop);
5281 range->op_next = leftstart;
5283 left->op_next = flip;
5284 right->op_next = flop;
5286 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5287 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5288 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5289 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5291 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5292 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5295 if (!flip->op_private || !flop->op_private)
5296 LINKLIST(o); /* blow off optimizer unless constant */
5302 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5304 Constructs, checks, and returns an op tree expressing a loop. This is
5305 only a loop in the control flow through the op tree; it does not have
5306 the heavyweight loop structure that allows exiting the loop by C<last>
5307 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5308 top-level op, except that some bits will be set automatically as required.
5309 I<expr> supplies the expression controlling loop iteration, and I<block>
5310 supplies the body of the loop; they are consumed by this function and
5311 become part of the constructed op tree. I<debuggable> is currently
5312 unused and should always be 1.
5318 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5323 const bool once = block && block->op_flags & OPf_SPECIAL &&
5324 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5326 PERL_UNUSED_ARG(debuggable);
5329 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5330 return block; /* do {} while 0 does once */
5331 if (expr->op_type == OP_READLINE
5332 || expr->op_type == OP_READDIR
5333 || expr->op_type == OP_GLOB
5334 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5335 expr = newUNOP(OP_DEFINED, 0,
5336 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5337 } else if (expr->op_flags & OPf_KIDS) {
5338 const OP * const k1 = ((UNOP*)expr)->op_first;
5339 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5340 switch (expr->op_type) {
5342 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5343 && (k2->op_flags & OPf_STACKED)
5344 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5345 expr = newUNOP(OP_DEFINED, 0, expr);
5349 if (k1 && (k1->op_type == OP_READDIR
5350 || k1->op_type == OP_GLOB
5351 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5352 || k1->op_type == OP_EACH))
5353 expr = newUNOP(OP_DEFINED, 0, expr);
5359 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5360 * op, in listop. This is wrong. [perl #27024] */
5362 block = newOP(OP_NULL, 0);
5363 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5364 o = new_logop(OP_AND, 0, &expr, &listop);
5367 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5369 if (once && o != listop)
5370 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5373 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5375 o->op_flags |= flags;
5377 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5382 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5384 Constructs, checks, and returns an op tree expressing a C<while> loop.
5385 This is a heavyweight loop, with structure that allows exiting the loop
5386 by C<last> and suchlike.
5388 I<loop> is an optional preconstructed C<enterloop> op to use in the
5389 loop; if it is null then a suitable op will be constructed automatically.
5390 I<expr> supplies the loop's controlling expression. I<block> supplies the
5391 main body of the loop, and I<cont> optionally supplies a C<continue> block
5392 that operates as a second half of the body. All of these optree inputs
5393 are consumed by this function and become part of the constructed op tree.
5395 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5396 op and, shifted up eight bits, the eight bits of C<op_private> for
5397 the C<leaveloop> op, except that (in both cases) some bits will be set
5398 automatically. I<debuggable> is currently unused and should always be 1.
5399 I<has_my> can be supplied as true to force the
5400 loop body to be enclosed in its own scope.
5406 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5407 OP *expr, OP *block, OP *cont, I32 has_my)
5416 PERL_UNUSED_ARG(debuggable);
5419 if (expr->op_type == OP_READLINE
5420 || expr->op_type == OP_READDIR
5421 || expr->op_type == OP_GLOB
5422 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5423 expr = newUNOP(OP_DEFINED, 0,
5424 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5425 } else if (expr->op_flags & OPf_KIDS) {
5426 const OP * const k1 = ((UNOP*)expr)->op_first;
5427 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5428 switch (expr->op_type) {
5430 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5431 && (k2->op_flags & OPf_STACKED)
5432 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5433 expr = newUNOP(OP_DEFINED, 0, expr);
5437 if (k1 && (k1->op_type == OP_READDIR
5438 || k1->op_type == OP_GLOB
5439 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5440 || k1->op_type == OP_EACH))
5441 expr = newUNOP(OP_DEFINED, 0, expr);
5448 block = newOP(OP_NULL, 0);
5449 else if (cont || has_my) {
5450 block = op_scope(block);
5454 next = LINKLIST(cont);
5457 OP * const unstack = newOP(OP_UNSTACK, 0);
5460 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5464 listop = op_append_list(OP_LINESEQ, block, cont);
5466 redo = LINKLIST(listop);
5470 o = new_logop(OP_AND, 0, &expr, &listop);
5471 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5472 op_free(expr); /* oops, it's a while (0) */
5474 return NULL; /* listop already freed by new_logop */
5477 ((LISTOP*)listop)->op_last->op_next =
5478 (o == listop ? redo : LINKLIST(o));
5484 NewOp(1101,loop,1,LOOP);
5485 loop->op_type = OP_ENTERLOOP;
5486 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5487 loop->op_private = 0;
5488 loop->op_next = (OP*)loop;
5491 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5493 loop->op_redoop = redo;
5494 loop->op_lastop = o;
5495 o->op_private |= loopflags;
5498 loop->op_nextop = next;
5500 loop->op_nextop = o;
5502 o->op_flags |= flags;
5503 o->op_private |= (flags >> 8);
5508 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5510 Constructs, checks, and returns an op tree expressing a C<foreach>
5511 loop (iteration through a list of values). This is a heavyweight loop,
5512 with structure that allows exiting the loop by C<last> and suchlike.
5514 I<sv> optionally supplies the variable that will be aliased to each
5515 item in turn; if null, it defaults to C<$_> (either lexical or global).
5516 I<expr> supplies the list of values to iterate over. I<block> supplies
5517 the main body of the loop, and I<cont> optionally supplies a C<continue>
5518 block that operates as a second half of the body. All of these optree
5519 inputs are consumed by this function and become part of the constructed
5522 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5523 op and, shifted up eight bits, the eight bits of C<op_private> for
5524 the C<leaveloop> op, except that (in both cases) some bits will be set
5531 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5536 PADOFFSET padoff = 0;
5541 PERL_ARGS_ASSERT_NEWFOROP;
5544 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5545 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5546 sv->op_type = OP_RV2GV;
5547 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5549 /* The op_type check is needed to prevent a possible segfault
5550 * if the loop variable is undeclared and 'strict vars' is in
5551 * effect. This is illegal but is nonetheless parsed, so we
5552 * may reach this point with an OP_CONST where we're expecting
5555 if (cUNOPx(sv)->op_first->op_type == OP_GV
5556 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5557 iterpflags |= OPpITER_DEF;
5559 else if (sv->op_type == OP_PADSV) { /* private variable */
5560 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5561 padoff = sv->op_targ;
5571 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5573 SV *const namesv = PAD_COMPNAME_SV(padoff);
5575 const char *const name = SvPV_const(namesv, len);
5577 if (len == 2 && name[0] == '$' && name[1] == '_')
5578 iterpflags |= OPpITER_DEF;
5582 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5583 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5584 sv = newGVOP(OP_GV, 0, PL_defgv);
5589 iterpflags |= OPpITER_DEF;
5591 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5592 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5593 iterflags |= OPf_STACKED;
5595 else if (expr->op_type == OP_NULL &&
5596 (expr->op_flags & OPf_KIDS) &&
5597 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5599 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5600 * set the STACKED flag to indicate that these values are to be
5601 * treated as min/max values by 'pp_iterinit'.
5603 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5604 LOGOP* const range = (LOGOP*) flip->op_first;
5605 OP* const left = range->op_first;
5606 OP* const right = left->op_sibling;
5609 range->op_flags &= ~OPf_KIDS;
5610 range->op_first = NULL;
5612 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5613 listop->op_first->op_next = range->op_next;
5614 left->op_next = range->op_other;
5615 right->op_next = (OP*)listop;
5616 listop->op_next = listop->op_first;
5619 op_getmad(expr,(OP*)listop,'O');
5623 expr = (OP*)(listop);
5625 iterflags |= OPf_STACKED;
5628 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5631 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5632 op_append_elem(OP_LIST, expr, scalar(sv))));
5633 assert(!loop->op_next);
5634 /* for my $x () sets OPpLVAL_INTRO;
5635 * for our $x () sets OPpOUR_INTRO */
5636 loop->op_private = (U8)iterpflags;
5637 #ifdef PL_OP_SLAB_ALLOC
5640 NewOp(1234,tmp,1,LOOP);
5641 Copy(loop,tmp,1,LISTOP);
5642 S_op_destroy(aTHX_ (OP*)loop);
5646 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5648 loop->op_targ = padoff;
5649 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5651 op_getmad(madsv, (OP*)loop, 'v');
5656 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5658 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5659 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5660 determining the target of the op; it is consumed by this function and
5661 become part of the constructed op tree.
5667 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5672 PERL_ARGS_ASSERT_NEWLOOPEX;
5674 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5676 if (type != OP_GOTO || label->op_type == OP_CONST) {
5677 /* "last()" means "last" */
5678 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5679 o = newOP(type, OPf_SPECIAL);
5681 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5682 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5686 op_getmad(label,o,'L');
5692 /* Check whether it's going to be a goto &function */
5693 if (label->op_type == OP_ENTERSUB
5694 && !(label->op_flags & OPf_STACKED))
5695 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5696 o = newUNOP(type, OPf_STACKED, label);
5698 PL_hints |= HINT_BLOCK_SCOPE;
5702 /* if the condition is a literal array or hash
5703 (or @{ ... } etc), make a reference to it.
5706 S_ref_array_or_hash(pTHX_ OP *cond)
5709 && (cond->op_type == OP_RV2AV
5710 || cond->op_type == OP_PADAV
5711 || cond->op_type == OP_RV2HV
5712 || cond->op_type == OP_PADHV))
5714 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5717 && (cond->op_type == OP_ASLICE
5718 || cond->op_type == OP_HSLICE)) {
5720 /* anonlist now needs a list from this op, was previously used in
5722 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5723 cond->op_flags |= OPf_WANT_LIST;
5725 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5732 /* These construct the optree fragments representing given()
5735 entergiven and enterwhen are LOGOPs; the op_other pointer
5736 points up to the associated leave op. We need this so we
5737 can put it in the context and make break/continue work.
5738 (Also, of course, pp_enterwhen will jump straight to
5739 op_other if the match fails.)
5743 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5744 I32 enter_opcode, I32 leave_opcode,
5745 PADOFFSET entertarg)
5751 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5753 NewOp(1101, enterop, 1, LOGOP);
5754 enterop->op_type = (Optype)enter_opcode;
5755 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5756 enterop->op_flags = (U8) OPf_KIDS;
5757 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5758 enterop->op_private = 0;
5760 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5763 enterop->op_first = scalar(cond);
5764 cond->op_sibling = block;
5766 o->op_next = LINKLIST(cond);
5767 cond->op_next = (OP *) enterop;
5770 /* This is a default {} block */
5771 enterop->op_first = block;
5772 enterop->op_flags |= OPf_SPECIAL;
5774 o->op_next = (OP *) enterop;
5777 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5778 entergiven and enterwhen both
5781 enterop->op_next = LINKLIST(block);
5782 block->op_next = enterop->op_other = o;
5787 /* Does this look like a boolean operation? For these purposes
5788 a boolean operation is:
5789 - a subroutine call [*]
5790 - a logical connective
5791 - a comparison operator
5792 - a filetest operator, with the exception of -s -M -A -C
5793 - defined(), exists() or eof()
5794 - /$re/ or $foo =~ /$re/
5796 [*] possibly surprising
5799 S_looks_like_bool(pTHX_ const OP *o)
5803 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5805 switch(o->op_type) {
5808 return looks_like_bool(cLOGOPo->op_first);
5812 looks_like_bool(cLOGOPo->op_first)
5813 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5818 o->op_flags & OPf_KIDS
5819 && looks_like_bool(cUNOPo->op_first));
5823 case OP_NOT: case OP_XOR:
5825 case OP_EQ: case OP_NE: case OP_LT:
5826 case OP_GT: case OP_LE: case OP_GE:
5828 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5829 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5831 case OP_SEQ: case OP_SNE: case OP_SLT:
5832 case OP_SGT: case OP_SLE: case OP_SGE:
5836 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5837 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5838 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5839 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5840 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5841 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5842 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5843 case OP_FTTEXT: case OP_FTBINARY:
5845 case OP_DEFINED: case OP_EXISTS:
5846 case OP_MATCH: case OP_EOF:
5853 /* Detect comparisons that have been optimized away */
5854 if (cSVOPo->op_sv == &PL_sv_yes
5855 || cSVOPo->op_sv == &PL_sv_no)
5868 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5870 Constructs, checks, and returns an op tree expressing a C<given> block.
5871 I<cond> supplies the expression that will be locally assigned to a lexical
5872 variable, and I<block> supplies the body of the C<given> construct; they
5873 are consumed by this function and become part of the constructed op tree.
5874 I<defsv_off> is the pad offset of the scalar lexical variable that will
5881 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5884 PERL_ARGS_ASSERT_NEWGIVENOP;
5885 return newGIVWHENOP(
5886 ref_array_or_hash(cond),
5888 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5893 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5895 Constructs, checks, and returns an op tree expressing a C<when> block.
5896 I<cond> supplies the test expression, and I<block> supplies the block
5897 that will be executed if the test evaluates to true; they are consumed
5898 by this function and become part of the constructed op tree. I<cond>
5899 will be interpreted DWIMically, often as a comparison against C<$_>,
5900 and may be null to generate a C<default> block.
5906 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5908 const bool cond_llb = (!cond || looks_like_bool(cond));
5911 PERL_ARGS_ASSERT_NEWWHENOP;
5916 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5918 scalar(ref_array_or_hash(cond)));
5921 return newGIVWHENOP(
5923 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5924 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5928 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5931 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5933 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5934 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5935 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5936 || (p && (len != SvCUR(cv) /* Not the same length. */
5937 || memNE(p, SvPVX_const(cv), len))))
5938 && ckWARN_d(WARN_PROTOTYPE)) {
5939 SV* const msg = sv_newmortal();
5943 gv_efullname3(name = sv_newmortal(), gv, NULL);
5944 sv_setpvs(msg, "Prototype mismatch:");
5946 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5948 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5950 sv_catpvs(msg, ": none");
5951 sv_catpvs(msg, " vs ");
5953 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5955 sv_catpvs(msg, "none");
5956 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5960 static void const_sv_xsub(pTHX_ CV* cv);
5964 =head1 Optree Manipulation Functions
5966 =for apidoc cv_const_sv
5968 If C<cv> is a constant sub eligible for inlining. returns the constant
5969 value returned by the sub. Otherwise, returns NULL.
5971 Constant subs can be created with C<newCONSTSUB> or as described in
5972 L<perlsub/"Constant Functions">.
5977 Perl_cv_const_sv(pTHX_ const CV *const cv)
5979 PERL_UNUSED_CONTEXT;
5982 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5984 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5987 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5988 * Can be called in 3 ways:
5991 * look for a single OP_CONST with attached value: return the value
5993 * cv && CvCLONE(cv) && !CvCONST(cv)
5995 * examine the clone prototype, and if contains only a single
5996 * OP_CONST referencing a pad const, or a single PADSV referencing
5997 * an outer lexical, return a non-zero value to indicate the CV is
5998 * a candidate for "constizing" at clone time
6002 * We have just cloned an anon prototype that was marked as a const
6003 * candidiate. Try to grab the current value, and in the case of
6004 * PADSV, ignore it if it has multiple references. Return the value.
6008 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6019 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6020 o = cLISTOPo->op_first->op_sibling;
6022 for (; o; o = o->op_next) {
6023 const OPCODE type = o->op_type;
6025 if (sv && o->op_next == o)
6027 if (o->op_next != o) {
6028 if (type == OP_NEXTSTATE
6029 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6030 || type == OP_PUSHMARK)
6032 if (type == OP_DBSTATE)
6035 if (type == OP_LEAVESUB || type == OP_RETURN)
6039 if (type == OP_CONST && cSVOPo->op_sv)
6041 else if (cv && type == OP_CONST) {
6042 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6046 else if (cv && type == OP_PADSV) {
6047 if (CvCONST(cv)) { /* newly cloned anon */
6048 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6049 /* the candidate should have 1 ref from this pad and 1 ref
6050 * from the parent */
6051 if (!sv || SvREFCNT(sv) != 2)
6058 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6059 sv = &PL_sv_undef; /* an arbitrary non-null value */
6074 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6077 /* This would be the return value, but the return cannot be reached. */
6078 OP* pegop = newOP(OP_NULL, 0);
6081 PERL_UNUSED_ARG(floor);
6091 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6093 NORETURN_FUNCTION_END;
6098 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6103 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6104 register CV *cv = NULL;
6106 /* If the subroutine has no body, no attributes, and no builtin attributes
6107 then it's just a sub declaration, and we may be able to get away with
6108 storing with a placeholder scalar in the symbol table, rather than a
6109 full GV and CV. If anything is present then it will take a full CV to
6111 const I32 gv_fetch_flags
6112 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6114 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6115 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6119 assert(proto->op_type == OP_CONST);
6120 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6126 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6128 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6129 SV * const sv = sv_newmortal();
6130 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6131 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6132 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6133 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6135 } else if (PL_curstash) {
6136 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6139 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6143 if (!PL_madskills) {
6152 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6153 maximum a prototype before. */
6154 if (SvTYPE(gv) > SVt_NULL) {
6155 if (!SvPOK((const SV *)gv)
6156 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6158 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6160 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6163 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6165 sv_setiv(MUTABLE_SV(gv), -1);
6167 SvREFCNT_dec(PL_compcv);
6168 cv = PL_compcv = NULL;
6172 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6174 if (!block || !ps || *ps || attrs
6175 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6177 || block->op_type == OP_NULL
6182 const_sv = op_const_sv(block, NULL);
6185 const bool exists = CvROOT(cv) || CvXSUB(cv);
6187 /* if the subroutine doesn't exist and wasn't pre-declared
6188 * with a prototype, assume it will be AUTOLOADed,
6189 * skipping the prototype check
6191 if (exists || SvPOK(cv))
6192 cv_ckproto_len(cv, gv, ps, ps_len);
6193 /* already defined (or promised)? */
6194 if (exists || GvASSUMECV(gv)) {
6197 || block->op_type == OP_NULL
6200 if (CvFLAGS(PL_compcv)) {
6201 /* might have had built-in attrs applied */
6202 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6203 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6204 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6206 /* just a "sub foo;" when &foo is already defined */
6207 SAVEFREESV(PL_compcv);
6212 && block->op_type != OP_NULL
6215 if (ckWARN(WARN_REDEFINE)
6217 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6219 const line_t oldline = CopLINE(PL_curcop);
6220 if (PL_parser && PL_parser->copline != NOLINE)
6221 CopLINE_set(PL_curcop, PL_parser->copline);
6222 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6223 CvCONST(cv) ? "Constant subroutine %s redefined"
6224 : "Subroutine %s redefined", name);
6225 CopLINE_set(PL_curcop, oldline);
6228 if (!PL_minus_c) /* keep old one around for madskills */
6231 /* (PL_madskills unset in used file.) */
6239 SvREFCNT_inc_simple_void_NN(const_sv);
6241 assert(!CvROOT(cv) && !CvCONST(cv));
6242 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6243 CvXSUBANY(cv).any_ptr = const_sv;
6244 CvXSUB(cv) = const_sv_xsub;
6250 cv = newCONSTSUB(NULL, name, const_sv);
6252 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6253 (CvGV(cv) && GvSTASH(CvGV(cv)))
6262 SvREFCNT_dec(PL_compcv);
6266 if (cv) { /* must reuse cv if autoloaded */
6267 /* transfer PL_compcv to cv */
6270 && block->op_type != OP_NULL
6273 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6274 AV *const temp_av = CvPADLIST(cv);
6275 CV *const temp_cv = CvOUTSIDE(cv);
6277 assert(!CvWEAKOUTSIDE(cv));
6278 assert(!CvCVGV_RC(cv));
6279 assert(CvGV(cv) == gv);
6282 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6283 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6284 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6285 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6286 CvOUTSIDE(PL_compcv) = temp_cv;
6287 CvPADLIST(PL_compcv) = temp_av;
6290 if (CvFILE(cv) && !CvISXSUB(cv)) {
6291 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6292 Safefree(CvFILE(cv));
6295 CvFILE_set_from_cop(cv, PL_curcop);
6296 CvSTASH_set(cv, PL_curstash);
6298 /* inner references to PL_compcv must be fixed up ... */
6299 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6300 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6301 ++PL_sub_generation;
6304 /* Might have had built-in attributes applied -- propagate them. */
6305 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6307 /* ... before we throw it away */
6308 SvREFCNT_dec(PL_compcv);
6316 if (strEQ(name, "import")) {
6317 PL_formfeed = MUTABLE_SV(cv);
6318 /* diag_listed_as: SKIPME */
6319 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6323 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6328 CvFILE_set_from_cop(cv, PL_curcop);
6329 CvSTASH_set(cv, PL_curstash);
6332 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6333 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6334 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6338 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6340 if (PL_parser && PL_parser->error_count) {
6344 const char *s = strrchr(name, ':');
6346 if (strEQ(s, "BEGIN")) {
6347 const char not_safe[] =
6348 "BEGIN not safe after errors--compilation aborted";
6349 if (PL_in_eval & EVAL_KEEPERR)
6350 Perl_croak(aTHX_ not_safe);
6352 /* force display of errors found but not reported */
6353 sv_catpv(ERRSV, not_safe);
6354 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6363 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6364 the debugger could be able to set a breakpoint in, so signal to
6365 pp_entereval that it should not throw away any saved lines at scope
6368 PL_breakable_sub_gen++;
6370 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6371 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6372 block->op_attached = 1;
6375 /* This makes sub {}; work as expected. */
6376 if (block->op_type == OP_STUB) {
6377 OP* const newblock = newSTATEOP(0, NULL, 0);
6379 op_getmad(block,newblock,'B');
6386 block->op_attached = 1;
6387 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6389 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6390 OpREFCNT_set(CvROOT(cv), 1);
6391 CvSTART(cv) = LINKLIST(CvROOT(cv));
6392 CvROOT(cv)->op_next = 0;
6393 CALL_PEEP(CvSTART(cv));
6395 /* now that optimizer has done its work, adjust pad values */
6397 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6400 assert(!CvCONST(cv));
6401 if (ps && !*ps && op_const_sv(block, cv))
6406 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6407 SV * const tmpstr = sv_newmortal();
6408 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6409 GV_ADDMULTI, SVt_PVHV);
6411 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6414 (long)CopLINE(PL_curcop));
6415 gv_efullname3(tmpstr, gv, NULL);
6416 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6417 SvCUR(tmpstr), sv, 0);
6418 hv = GvHVn(db_postponed);
6419 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6420 CV * const pcv = GvCV(db_postponed);
6426 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6431 if (name && ! (PL_parser && PL_parser->error_count))
6432 process_special_blocks(name, gv, cv);
6437 PL_parser->copline = NOLINE;
6443 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6446 const char *const colon = strrchr(fullname,':');
6447 const char *const name = colon ? colon + 1 : fullname;
6449 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6452 if (strEQ(name, "BEGIN")) {
6453 const I32 oldscope = PL_scopestack_ix;
6455 SAVECOPFILE(&PL_compiling);
6456 SAVECOPLINE(&PL_compiling);
6458 DEBUG_x( dump_sub(gv) );
6459 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6460 GvCV(gv) = 0; /* cv has been hijacked */
6461 call_list(oldscope, PL_beginav);
6463 PL_curcop = &PL_compiling;
6464 CopHINTS_set(&PL_compiling, PL_hints);
6471 if strEQ(name, "END") {
6472 DEBUG_x( dump_sub(gv) );
6473 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6476 } else if (*name == 'U') {
6477 if (strEQ(name, "UNITCHECK")) {
6478 /* It's never too late to run a unitcheck block */
6479 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6483 } else if (*name == 'C') {
6484 if (strEQ(name, "CHECK")) {
6486 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6487 "Too late to run CHECK block");
6488 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6492 } else if (*name == 'I') {
6493 if (strEQ(name, "INIT")) {
6495 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6496 "Too late to run INIT block");
6497 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6503 DEBUG_x( dump_sub(gv) );
6504 GvCV(gv) = 0; /* cv has been hijacked */
6509 =for apidoc newCONSTSUB
6511 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6512 eligible for inlining at compile-time.
6514 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6515 which won't be called if used as a destructor, but will suppress the overhead
6516 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6523 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6528 const char *const file = CopFILE(PL_curcop);
6530 SV *const temp_sv = CopFILESV(PL_curcop);
6531 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6536 if (IN_PERL_RUNTIME) {
6537 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6538 * an op shared between threads. Use a non-shared COP for our
6540 SAVEVPTR(PL_curcop);
6541 PL_curcop = &PL_compiling;
6543 SAVECOPLINE(PL_curcop);
6544 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6547 PL_hints &= ~HINT_BLOCK_SCOPE;
6550 SAVESPTR(PL_curstash);
6551 SAVECOPSTASH(PL_curcop);
6552 PL_curstash = stash;
6553 CopSTASH_set(PL_curcop,stash);
6556 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6557 and so doesn't get free()d. (It's expected to be from the C pre-
6558 processor __FILE__ directive). But we need a dynamically allocated one,
6559 and we need it to get freed. */
6560 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6561 XS_DYNAMIC_FILENAME);
6562 CvXSUBANY(cv).any_ptr = sv;
6567 CopSTASH_free(PL_curcop);
6575 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6576 const char *const filename, const char *const proto,
6579 CV *cv = newXS(name, subaddr, filename);
6581 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6583 if (flags & XS_DYNAMIC_FILENAME) {
6584 /* We need to "make arrangements" (ie cheat) to ensure that the
6585 filename lasts as long as the PVCV we just created, but also doesn't
6587 STRLEN filename_len = strlen(filename);
6588 STRLEN proto_and_file_len = filename_len;
6589 char *proto_and_file;
6593 proto_len = strlen(proto);
6594 proto_and_file_len += proto_len;
6596 Newx(proto_and_file, proto_and_file_len + 1, char);
6597 Copy(proto, proto_and_file, proto_len, char);
6598 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6601 proto_and_file = savepvn(filename, filename_len);
6604 /* This gets free()d. :-) */
6605 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6606 SV_HAS_TRAILING_NUL);
6608 /* This gives us the correct prototype, rather than one with the
6609 file name appended. */
6610 SvCUR_set(cv, proto_len);
6614 CvFILE(cv) = proto_and_file + proto_len;
6616 sv_setpv(MUTABLE_SV(cv), proto);
6622 =for apidoc U||newXS
6624 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6625 static storage, as it is used directly as CvFILE(), without a copy being made.
6631 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6634 GV * const gv = gv_fetchpv(name ? name :
6635 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6636 GV_ADDMULTI, SVt_PVCV);
6639 PERL_ARGS_ASSERT_NEWXS;
6642 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6644 if ((cv = (name ? GvCV(gv) : NULL))) {
6646 /* just a cached method */
6650 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6651 /* already defined (or promised) */
6652 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6653 if (ckWARN(WARN_REDEFINE)) {
6654 GV * const gvcv = CvGV(cv);
6656 HV * const stash = GvSTASH(gvcv);
6658 const char *redefined_name = HvNAME_get(stash);
6659 if ( strEQ(redefined_name,"autouse") ) {
6660 const line_t oldline = CopLINE(PL_curcop);
6661 if (PL_parser && PL_parser->copline != NOLINE)
6662 CopLINE_set(PL_curcop, PL_parser->copline);
6663 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6664 CvCONST(cv) ? "Constant subroutine %s redefined"
6665 : "Subroutine %s redefined"
6667 CopLINE_set(PL_curcop, oldline);
6677 if (cv) /* must reuse cv if autoloaded */
6680 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6684 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6690 (void)gv_fetchfile(filename);
6691 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6692 an external constant string */
6694 CvXSUB(cv) = subaddr;
6697 process_special_blocks(name, gv, cv);
6707 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6712 OP* pegop = newOP(OP_NULL, 0);
6716 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6717 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6720 if ((cv = GvFORM(gv))) {
6721 if (ckWARN(WARN_REDEFINE)) {
6722 const line_t oldline = CopLINE(PL_curcop);
6723 if (PL_parser && PL_parser->copline != NOLINE)
6724 CopLINE_set(PL_curcop, PL_parser->copline);
6726 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6727 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6729 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6730 "Format STDOUT redefined");
6732 CopLINE_set(PL_curcop, oldline);
6739 CvFILE_set_from_cop(cv, PL_curcop);
6742 pad_tidy(padtidy_FORMAT);
6743 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6744 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6745 OpREFCNT_set(CvROOT(cv), 1);
6746 CvSTART(cv) = LINKLIST(CvROOT(cv));
6747 CvROOT(cv)->op_next = 0;
6748 CALL_PEEP(CvSTART(cv));
6750 op_getmad(o,pegop,'n');
6751 op_getmad_weak(block, pegop, 'b');
6756 PL_parser->copline = NOLINE;
6764 Perl_newANONLIST(pTHX_ OP *o)
6766 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6770 Perl_newANONHASH(pTHX_ OP *o)
6772 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6776 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6778 return newANONATTRSUB(floor, proto, NULL, block);
6782 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6784 return newUNOP(OP_REFGEN, 0,
6785 newSVOP(OP_ANONCODE, 0,
6786 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6790 Perl_oopsAV(pTHX_ OP *o)
6794 PERL_ARGS_ASSERT_OOPSAV;
6796 switch (o->op_type) {
6798 o->op_type = OP_PADAV;
6799 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6800 return ref(o, OP_RV2AV);
6803 o->op_type = OP_RV2AV;
6804 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6809 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6816 Perl_oopsHV(pTHX_ OP *o)
6820 PERL_ARGS_ASSERT_OOPSHV;
6822 switch (o->op_type) {
6825 o->op_type = OP_PADHV;
6826 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6827 return ref(o, OP_RV2HV);
6831 o->op_type = OP_RV2HV;
6832 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6837 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6844 Perl_newAVREF(pTHX_ OP *o)
6848 PERL_ARGS_ASSERT_NEWAVREF;
6850 if (o->op_type == OP_PADANY) {
6851 o->op_type = OP_PADAV;
6852 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6855 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6856 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6857 "Using an array as a reference is deprecated");
6859 return newUNOP(OP_RV2AV, 0, scalar(o));
6863 Perl_newGVREF(pTHX_ I32 type, OP *o)
6865 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6866 return newUNOP(OP_NULL, 0, o);
6867 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6871 Perl_newHVREF(pTHX_ OP *o)
6875 PERL_ARGS_ASSERT_NEWHVREF;
6877 if (o->op_type == OP_PADANY) {
6878 o->op_type = OP_PADHV;
6879 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6882 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6883 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6884 "Using a hash as a reference is deprecated");
6886 return newUNOP(OP_RV2HV, 0, scalar(o));
6890 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6892 return newUNOP(OP_RV2CV, flags, scalar(o));
6896 Perl_newSVREF(pTHX_ OP *o)
6900 PERL_ARGS_ASSERT_NEWSVREF;
6902 if (o->op_type == OP_PADANY) {
6903 o->op_type = OP_PADSV;
6904 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6907 return newUNOP(OP_RV2SV, 0, scalar(o));
6910 /* Check routines. See the comments at the top of this file for details
6911 * on when these are called */
6914 Perl_ck_anoncode(pTHX_ OP *o)
6916 PERL_ARGS_ASSERT_CK_ANONCODE;
6918 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6920 cSVOPo->op_sv = NULL;
6925 Perl_ck_bitop(pTHX_ OP *o)
6929 PERL_ARGS_ASSERT_CK_BITOP;
6931 #define OP_IS_NUMCOMPARE(op) \
6932 ((op) == OP_LT || (op) == OP_I_LT || \
6933 (op) == OP_GT || (op) == OP_I_GT || \
6934 (op) == OP_LE || (op) == OP_I_LE || \
6935 (op) == OP_GE || (op) == OP_I_GE || \
6936 (op) == OP_EQ || (op) == OP_I_EQ || \
6937 (op) == OP_NE || (op) == OP_I_NE || \
6938 (op) == OP_NCMP || (op) == OP_I_NCMP)
6939 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6940 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6941 && (o->op_type == OP_BIT_OR
6942 || o->op_type == OP_BIT_AND
6943 || o->op_type == OP_BIT_XOR))
6945 const OP * const left = cBINOPo->op_first;
6946 const OP * const right = left->op_sibling;
6947 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6948 (left->op_flags & OPf_PARENS) == 0) ||
6949 (OP_IS_NUMCOMPARE(right->op_type) &&
6950 (right->op_flags & OPf_PARENS) == 0))
6951 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6952 "Possible precedence problem on bitwise %c operator",
6953 o->op_type == OP_BIT_OR ? '|'
6954 : o->op_type == OP_BIT_AND ? '&' : '^'
6961 Perl_ck_concat(pTHX_ OP *o)
6963 const OP * const kid = cUNOPo->op_first;
6965 PERL_ARGS_ASSERT_CK_CONCAT;
6966 PERL_UNUSED_CONTEXT;
6968 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6969 !(kUNOP->op_first->op_flags & OPf_MOD))
6970 o->op_flags |= OPf_STACKED;
6975 Perl_ck_spair(pTHX_ OP *o)
6979 PERL_ARGS_ASSERT_CK_SPAIR;
6981 if (o->op_flags & OPf_KIDS) {
6984 const OPCODE type = o->op_type;
6985 o = modkids(ck_fun(o), type);
6986 kid = cUNOPo->op_first;
6987 newop = kUNOP->op_first->op_sibling;
6989 const OPCODE type = newop->op_type;
6990 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6991 type == OP_PADAV || type == OP_PADHV ||
6992 type == OP_RV2AV || type == OP_RV2HV)
6996 op_getmad(kUNOP->op_first,newop,'K');
6998 op_free(kUNOP->op_first);
7000 kUNOP->op_first = newop;
7002 o->op_ppaddr = PL_ppaddr[++o->op_type];
7007 Perl_ck_delete(pTHX_ OP *o)
7009 PERL_ARGS_ASSERT_CK_DELETE;
7013 if (o->op_flags & OPf_KIDS) {
7014 OP * const kid = cUNOPo->op_first;
7015 switch (kid->op_type) {
7017 o->op_flags |= OPf_SPECIAL;
7020 o->op_private |= OPpSLICE;
7023 o->op_flags |= OPf_SPECIAL;
7028 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7031 if (kid->op_private & OPpLVAL_INTRO)
7032 o->op_private |= OPpLVAL_INTRO;
7039 Perl_ck_die(pTHX_ OP *o)
7041 PERL_ARGS_ASSERT_CK_DIE;
7044 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7050 Perl_ck_eof(pTHX_ OP *o)
7054 PERL_ARGS_ASSERT_CK_EOF;
7056 if (o->op_flags & OPf_KIDS) {
7057 if (cLISTOPo->op_first->op_type == OP_STUB) {
7059 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7061 op_getmad(o,newop,'O');
7073 Perl_ck_eval(pTHX_ OP *o)
7077 PERL_ARGS_ASSERT_CK_EVAL;
7079 PL_hints |= HINT_BLOCK_SCOPE;
7080 if (o->op_flags & OPf_KIDS) {
7081 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7084 o->op_flags &= ~OPf_KIDS;
7087 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7093 cUNOPo->op_first = 0;
7098 NewOp(1101, enter, 1, LOGOP);
7099 enter->op_type = OP_ENTERTRY;
7100 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7101 enter->op_private = 0;
7103 /* establish postfix order */
7104 enter->op_next = (OP*)enter;
7106 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7107 o->op_type = OP_LEAVETRY;
7108 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7109 enter->op_other = o;
7110 op_getmad(oldo,o,'O');
7124 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7125 op_getmad(oldo,o,'O');
7127 o->op_targ = (PADOFFSET)PL_hints;
7128 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7129 /* Store a copy of %^H that pp_entereval can pick up. */
7130 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7131 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7132 cUNOPo->op_first->op_sibling = hhop;
7133 o->op_private |= OPpEVAL_HAS_HH;
7139 Perl_ck_exit(pTHX_ OP *o)
7141 PERL_ARGS_ASSERT_CK_EXIT;
7144 HV * const table = GvHV(PL_hintgv);
7146 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7147 if (svp && *svp && SvTRUE(*svp))
7148 o->op_private |= OPpEXIT_VMSISH;
7150 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7156 Perl_ck_exec(pTHX_ OP *o)
7158 PERL_ARGS_ASSERT_CK_EXEC;
7160 if (o->op_flags & OPf_STACKED) {
7163 kid = cUNOPo->op_first->op_sibling;
7164 if (kid->op_type == OP_RV2GV)
7173 Perl_ck_exists(pTHX_ OP *o)
7177 PERL_ARGS_ASSERT_CK_EXISTS;
7180 if (o->op_flags & OPf_KIDS) {
7181 OP * const kid = cUNOPo->op_first;
7182 if (kid->op_type == OP_ENTERSUB) {
7183 (void) ref(kid, o->op_type);
7184 if (kid->op_type != OP_RV2CV
7185 && !(PL_parser && PL_parser->error_count))
7186 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7188 o->op_private |= OPpEXISTS_SUB;
7190 else if (kid->op_type == OP_AELEM)
7191 o->op_flags |= OPf_SPECIAL;
7192 else if (kid->op_type != OP_HELEM)
7193 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7201 Perl_ck_rvconst(pTHX_ register OP *o)
7204 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7206 PERL_ARGS_ASSERT_CK_RVCONST;
7208 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7209 if (o->op_type == OP_RV2CV)
7210 o->op_private &= ~1;
7212 if (kid->op_type == OP_CONST) {
7215 SV * const kidsv = kid->op_sv;
7217 /* Is it a constant from cv_const_sv()? */
7218 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7219 SV * const rsv = SvRV(kidsv);
7220 const svtype type = SvTYPE(rsv);
7221 const char *badtype = NULL;
7223 switch (o->op_type) {
7225 if (type > SVt_PVMG)
7226 badtype = "a SCALAR";
7229 if (type != SVt_PVAV)
7230 badtype = "an ARRAY";
7233 if (type != SVt_PVHV)
7237 if (type != SVt_PVCV)
7242 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7245 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7246 const char *badthing;
7247 switch (o->op_type) {
7249 badthing = "a SCALAR";
7252 badthing = "an ARRAY";
7255 badthing = "a HASH";
7263 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7264 SVfARG(kidsv), badthing);
7267 * This is a little tricky. We only want to add the symbol if we
7268 * didn't add it in the lexer. Otherwise we get duplicate strict
7269 * warnings. But if we didn't add it in the lexer, we must at
7270 * least pretend like we wanted to add it even if it existed before,
7271 * or we get possible typo warnings. OPpCONST_ENTERED says
7272 * whether the lexer already added THIS instance of this symbol.
7274 iscv = (o->op_type == OP_RV2CV) * 2;
7276 gv = gv_fetchsv(kidsv,
7277 iscv | !(kid->op_private & OPpCONST_ENTERED),
7280 : o->op_type == OP_RV2SV
7282 : o->op_type == OP_RV2AV
7284 : o->op_type == OP_RV2HV
7287 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7289 kid->op_type = OP_GV;
7290 SvREFCNT_dec(kid->op_sv);
7292 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7293 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7294 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7296 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7298 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7300 kid->op_private = 0;
7301 kid->op_ppaddr = PL_ppaddr[OP_GV];
7302 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7310 Perl_ck_ftst(pTHX_ OP *o)
7313 const I32 type = o->op_type;
7315 PERL_ARGS_ASSERT_CK_FTST;
7317 if (o->op_flags & OPf_REF) {
7320 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7321 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7322 const OPCODE kidtype = kid->op_type;
7324 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7325 OP * const newop = newGVOP(type, OPf_REF,
7326 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7328 op_getmad(o,newop,'O');
7334 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7335 o->op_private |= OPpFT_ACCESS;
7336 if (PL_check[kidtype] == Perl_ck_ftst
7337 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7338 o->op_private |= OPpFT_STACKED;
7346 if (type == OP_FTTTY)
7347 o = newGVOP(type, OPf_REF, PL_stdingv);
7349 o = newUNOP(type, 0, newDEFSVOP());
7350 op_getmad(oldo,o,'O');
7356 Perl_ck_fun(pTHX_ OP *o)
7359 const int type = o->op_type;
7360 register I32 oa = PL_opargs[type] >> OASHIFT;
7362 PERL_ARGS_ASSERT_CK_FUN;
7364 if (o->op_flags & OPf_STACKED) {
7365 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7368 return no_fh_allowed(o);
7371 if (o->op_flags & OPf_KIDS) {
7372 OP **tokid = &cLISTOPo->op_first;
7373 register OP *kid = cLISTOPo->op_first;
7377 if (kid->op_type == OP_PUSHMARK ||
7378 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7380 tokid = &kid->op_sibling;
7381 kid = kid->op_sibling;
7383 if (!kid && PL_opargs[type] & OA_DEFGV)
7384 *tokid = kid = newDEFSVOP();
7388 sibl = kid->op_sibling;
7390 if (!sibl && kid->op_type == OP_STUB) {
7397 /* list seen where single (scalar) arg expected? */
7398 if (numargs == 1 && !(oa >> 4)
7399 && kid->op_type == OP_LIST && type != OP_SCALAR)
7401 return too_many_arguments(o,PL_op_desc[type]);
7414 if ((type == OP_PUSH || type == OP_UNSHIFT)
7415 && !kid->op_sibling)
7416 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7417 "Useless use of %s with no values",
7420 if (kid->op_type == OP_CONST &&
7421 (kid->op_private & OPpCONST_BARE))
7423 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7424 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7425 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7426 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7427 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7429 op_getmad(kid,newop,'K');
7434 kid->op_sibling = sibl;
7437 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7438 bad_type(numargs, "array", PL_op_desc[type], kid);
7439 op_lvalue(kid, type);
7442 if (kid->op_type == OP_CONST &&
7443 (kid->op_private & OPpCONST_BARE))
7445 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7446 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7447 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7448 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7449 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7451 op_getmad(kid,newop,'K');
7456 kid->op_sibling = sibl;
7459 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7460 bad_type(numargs, "hash", PL_op_desc[type], kid);
7461 op_lvalue(kid, type);
7465 OP * const newop = newUNOP(OP_NULL, 0, kid);
7466 kid->op_sibling = 0;
7468 newop->op_next = newop;
7470 kid->op_sibling = sibl;
7475 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7476 if (kid->op_type == OP_CONST &&
7477 (kid->op_private & OPpCONST_BARE))
7479 OP * const newop = newGVOP(OP_GV, 0,
7480 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7481 if (!(o->op_private & 1) && /* if not unop */
7482 kid == cLISTOPo->op_last)
7483 cLISTOPo->op_last = newop;
7485 op_getmad(kid,newop,'K');
7491 else if (kid->op_type == OP_READLINE) {
7492 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7493 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7496 I32 flags = OPf_SPECIAL;
7500 /* is this op a FH constructor? */
7501 if (is_handle_constructor(o,numargs)) {
7502 const char *name = NULL;
7506 /* Set a flag to tell rv2gv to vivify
7507 * need to "prove" flag does not mean something
7508 * else already - NI-S 1999/05/07
7511 if (kid->op_type == OP_PADSV) {
7513 = PAD_COMPNAME_SV(kid->op_targ);
7514 name = SvPV_const(namesv, len);
7516 else if (kid->op_type == OP_RV2SV
7517 && kUNOP->op_first->op_type == OP_GV)
7519 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7521 len = GvNAMELEN(gv);
7523 else if (kid->op_type == OP_AELEM
7524 || kid->op_type == OP_HELEM)
7527 OP *op = ((BINOP*)kid)->op_first;
7531 const char * const a =
7532 kid->op_type == OP_AELEM ?
7534 if (((op->op_type == OP_RV2AV) ||
7535 (op->op_type == OP_RV2HV)) &&
7536 (firstop = ((UNOP*)op)->op_first) &&
7537 (firstop->op_type == OP_GV)) {
7538 /* packagevar $a[] or $h{} */
7539 GV * const gv = cGVOPx_gv(firstop);
7547 else if (op->op_type == OP_PADAV
7548 || op->op_type == OP_PADHV) {
7549 /* lexicalvar $a[] or $h{} */
7550 const char * const padname =
7551 PAD_COMPNAME_PV(op->op_targ);
7560 name = SvPV_const(tmpstr, len);
7565 name = "__ANONIO__";
7568 op_lvalue(kid, type);
7572 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7573 namesv = PAD_SVl(targ);
7574 SvUPGRADE(namesv, SVt_PV);
7576 sv_setpvs(namesv, "$");
7577 sv_catpvn(namesv, name, len);
7580 kid->op_sibling = 0;
7581 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7582 kid->op_targ = targ;
7583 kid->op_private |= priv;
7585 kid->op_sibling = sibl;
7591 op_lvalue(scalar(kid), type);
7595 tokid = &kid->op_sibling;
7596 kid = kid->op_sibling;
7599 if (kid && kid->op_type != OP_STUB)
7600 return too_many_arguments(o,OP_DESC(o));
7601 o->op_private |= numargs;
7603 /* FIXME - should the numargs move as for the PERL_MAD case? */
7604 o->op_private |= numargs;
7606 return too_many_arguments(o,OP_DESC(o));
7610 else if (PL_opargs[type] & OA_DEFGV) {
7612 OP *newop = newUNOP(type, 0, newDEFSVOP());
7613 op_getmad(o,newop,'O');
7616 /* Ordering of these two is important to keep f_map.t passing. */
7618 return newUNOP(type, 0, newDEFSVOP());
7623 while (oa & OA_OPTIONAL)
7625 if (oa && oa != OA_LIST)
7626 return too_few_arguments(o,OP_DESC(o));
7632 Perl_ck_glob(pTHX_ OP *o)
7637 PERL_ARGS_ASSERT_CK_GLOB;
7640 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7641 op_append_elem(OP_GLOB, o, newDEFSVOP());
7643 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7644 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7646 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7649 #if !defined(PERL_EXTERNAL_GLOB)
7650 /* XXX this can be tightened up and made more failsafe. */
7651 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7654 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7655 newSVpvs("File::Glob"), NULL, NULL, NULL);
7656 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7657 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7658 GvCV(gv) = GvCV(glob_gv);
7659 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7660 GvIMPORTED_CV_on(gv);
7664 #endif /* PERL_EXTERNAL_GLOB */
7666 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7667 op_append_elem(OP_GLOB, o,
7668 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7669 o->op_type = OP_LIST;
7670 o->op_ppaddr = PL_ppaddr[OP_LIST];
7671 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7672 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7673 cLISTOPo->op_first->op_targ = 0;
7674 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7675 op_append_elem(OP_LIST, o,
7676 scalar(newUNOP(OP_RV2CV, 0,
7677 newGVOP(OP_GV, 0, gv)))));
7678 o = newUNOP(OP_NULL, 0, ck_subr(o));
7679 o->op_targ = OP_GLOB; /* hint at what it used to be */
7682 gv = newGVgen("main");
7684 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7690 Perl_ck_grep(pTHX_ OP *o)
7695 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7698 PERL_ARGS_ASSERT_CK_GREP;
7700 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7701 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7703 if (o->op_flags & OPf_STACKED) {
7706 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7707 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7708 return no_fh_allowed(o);
7709 for (k = kid; k; k = k->op_next) {
7712 NewOp(1101, gwop, 1, LOGOP);
7713 kid->op_next = (OP*)gwop;
7714 o->op_flags &= ~OPf_STACKED;
7716 kid = cLISTOPo->op_first->op_sibling;
7717 if (type == OP_MAPWHILE)
7722 if (PL_parser && PL_parser->error_count)
7724 kid = cLISTOPo->op_first->op_sibling;
7725 if (kid->op_type != OP_NULL)
7726 Perl_croak(aTHX_ "panic: ck_grep");
7727 kid = kUNOP->op_first;
7730 NewOp(1101, gwop, 1, LOGOP);
7731 gwop->op_type = type;
7732 gwop->op_ppaddr = PL_ppaddr[type];
7733 gwop->op_first = listkids(o);
7734 gwop->op_flags |= OPf_KIDS;
7735 gwop->op_other = LINKLIST(kid);
7736 kid->op_next = (OP*)gwop;
7737 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7738 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7739 o->op_private = gwop->op_private = 0;
7740 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7743 o->op_private = gwop->op_private = OPpGREP_LEX;
7744 gwop->op_targ = o->op_targ = offset;
7747 kid = cLISTOPo->op_first->op_sibling;
7748 if (!kid || !kid->op_sibling)
7749 return too_few_arguments(o,OP_DESC(o));
7750 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7751 op_lvalue(kid, OP_GREPSTART);
7757 Perl_ck_index(pTHX_ OP *o)
7759 PERL_ARGS_ASSERT_CK_INDEX;
7761 if (o->op_flags & OPf_KIDS) {
7762 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7764 kid = kid->op_sibling; /* get past "big" */
7765 if (kid && kid->op_type == OP_CONST)
7766 fbm_compile(((SVOP*)kid)->op_sv, 0);
7772 Perl_ck_lfun(pTHX_ OP *o)
7774 const OPCODE type = o->op_type;
7776 PERL_ARGS_ASSERT_CK_LFUN;
7778 return modkids(ck_fun(o), type);
7782 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7784 PERL_ARGS_ASSERT_CK_DEFINED;
7786 if ((o->op_flags & OPf_KIDS)) {
7787 switch (cUNOPo->op_first->op_type) {
7789 /* This is needed for
7790 if (defined %stash::)
7791 to work. Do not break Tk.
7793 break; /* Globals via GV can be undef */
7795 case OP_AASSIGN: /* Is this a good idea? */
7796 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7797 "defined(@array) is deprecated");
7798 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7799 "\t(Maybe you should just omit the defined()?)\n");
7803 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7804 "defined(%%hash) is deprecated");
7805 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7806 "\t(Maybe you should just omit the defined()?)\n");
7817 Perl_ck_readline(pTHX_ OP *o)
7819 PERL_ARGS_ASSERT_CK_READLINE;
7821 if (!(o->op_flags & OPf_KIDS)) {
7823 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7825 op_getmad(o,newop,'O');
7835 Perl_ck_rfun(pTHX_ OP *o)
7837 const OPCODE type = o->op_type;
7839 PERL_ARGS_ASSERT_CK_RFUN;
7841 return refkids(ck_fun(o), type);
7845 Perl_ck_listiob(pTHX_ OP *o)
7849 PERL_ARGS_ASSERT_CK_LISTIOB;
7851 kid = cLISTOPo->op_first;
7854 kid = cLISTOPo->op_first;
7856 if (kid->op_type == OP_PUSHMARK)
7857 kid = kid->op_sibling;
7858 if (kid && o->op_flags & OPf_STACKED)
7859 kid = kid->op_sibling;
7860 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7861 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7862 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7863 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7864 cLISTOPo->op_first->op_sibling = kid;
7865 cLISTOPo->op_last = kid;
7866 kid = kid->op_sibling;
7871 op_append_elem(o->op_type, o, newDEFSVOP());
7877 Perl_ck_smartmatch(pTHX_ OP *o)
7880 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7881 if (0 == (o->op_flags & OPf_SPECIAL)) {
7882 OP *first = cBINOPo->op_first;
7883 OP *second = first->op_sibling;
7885 /* Implicitly take a reference to an array or hash */
7886 first->op_sibling = NULL;
7887 first = cBINOPo->op_first = ref_array_or_hash(first);
7888 second = first->op_sibling = ref_array_or_hash(second);
7890 /* Implicitly take a reference to a regular expression */
7891 if (first->op_type == OP_MATCH) {
7892 first->op_type = OP_QR;
7893 first->op_ppaddr = PL_ppaddr[OP_QR];
7895 if (second->op_type == OP_MATCH) {
7896 second->op_type = OP_QR;
7897 second->op_ppaddr = PL_ppaddr[OP_QR];
7906 Perl_ck_sassign(pTHX_ OP *o)
7909 OP * const kid = cLISTOPo->op_first;
7911 PERL_ARGS_ASSERT_CK_SASSIGN;
7913 /* has a disposable target? */
7914 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7915 && !(kid->op_flags & OPf_STACKED)
7916 /* Cannot steal the second time! */
7917 && !(kid->op_private & OPpTARGET_MY)
7918 /* Keep the full thing for madskills */
7922 OP * const kkid = kid->op_sibling;
7924 /* Can just relocate the target. */
7925 if (kkid && kkid->op_type == OP_PADSV
7926 && !(kkid->op_private & OPpLVAL_INTRO))
7928 kid->op_targ = kkid->op_targ;
7930 /* Now we do not need PADSV and SASSIGN. */
7931 kid->op_sibling = o->op_sibling; /* NULL */
7932 cLISTOPo->op_first = NULL;
7935 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7939 if (kid->op_sibling) {
7940 OP *kkid = kid->op_sibling;
7941 /* For state variable assignment, kkid is a list op whose op_last
7943 if ((kkid->op_type == OP_PADSV ||
7944 (kkid->op_type == OP_LIST &&
7945 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
7948 && (kkid->op_private & OPpLVAL_INTRO)
7949 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7950 const PADOFFSET target = kkid->op_targ;
7951 OP *const other = newOP(OP_PADSV,
7953 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7954 OP *const first = newOP(OP_NULL, 0);
7955 OP *const nullop = newCONDOP(0, first, o, other);
7956 OP *const condop = first->op_next;
7957 /* hijacking PADSTALE for uninitialized state variables */
7958 SvPADSTALE_on(PAD_SVl(target));
7960 condop->op_type = OP_ONCE;
7961 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7962 condop->op_targ = target;
7963 other->op_targ = target;
7965 /* Because we change the type of the op here, we will skip the
7966 assinment binop->op_last = binop->op_first->op_sibling; at the
7967 end of Perl_newBINOP(). So need to do it here. */
7968 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7977 Perl_ck_match(pTHX_ OP *o)
7981 PERL_ARGS_ASSERT_CK_MATCH;
7983 if (o->op_type != OP_QR && PL_compcv) {
7984 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7985 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7986 o->op_targ = offset;
7987 o->op_private |= OPpTARGET_MY;
7990 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7991 o->op_private |= OPpRUNTIME;
7996 Perl_ck_method(pTHX_ OP *o)
7998 OP * const kid = cUNOPo->op_first;
8000 PERL_ARGS_ASSERT_CK_METHOD;
8002 if (kid->op_type == OP_CONST) {
8003 SV* sv = kSVOP->op_sv;
8004 const char * const method = SvPVX_const(sv);
8005 if (!(strchr(method, ':') || strchr(method, '\''))) {
8007 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8008 sv = newSVpvn_share(method, SvCUR(sv), 0);
8011 kSVOP->op_sv = NULL;
8013 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8015 op_getmad(o,cmop,'O');
8026 Perl_ck_null(pTHX_ OP *o)
8028 PERL_ARGS_ASSERT_CK_NULL;
8029 PERL_UNUSED_CONTEXT;
8034 Perl_ck_open(pTHX_ OP *o)
8037 HV * const table = GvHV(PL_hintgv);
8039 PERL_ARGS_ASSERT_CK_OPEN;
8042 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8045 const char *d = SvPV_const(*svp, len);
8046 const I32 mode = mode_from_discipline(d, len);
8047 if (mode & O_BINARY)
8048 o->op_private |= OPpOPEN_IN_RAW;
8049 else if (mode & O_TEXT)
8050 o->op_private |= OPpOPEN_IN_CRLF;
8053 svp = hv_fetchs(table, "open_OUT", FALSE);
8056 const char *d = SvPV_const(*svp, len);
8057 const I32 mode = mode_from_discipline(d, len);
8058 if (mode & O_BINARY)
8059 o->op_private |= OPpOPEN_OUT_RAW;
8060 else if (mode & O_TEXT)
8061 o->op_private |= OPpOPEN_OUT_CRLF;
8064 if (o->op_type == OP_BACKTICK) {
8065 if (!(o->op_flags & OPf_KIDS)) {
8066 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8068 op_getmad(o,newop,'O');
8077 /* In case of three-arg dup open remove strictness
8078 * from the last arg if it is a bareword. */
8079 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8080 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8084 if ((last->op_type == OP_CONST) && /* The bareword. */
8085 (last->op_private & OPpCONST_BARE) &&
8086 (last->op_private & OPpCONST_STRICT) &&
8087 (oa = first->op_sibling) && /* The fh. */
8088 (oa = oa->op_sibling) && /* The mode. */
8089 (oa->op_type == OP_CONST) &&
8090 SvPOK(((SVOP*)oa)->op_sv) &&
8091 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8092 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8093 (last == oa->op_sibling)) /* The bareword. */
8094 last->op_private &= ~OPpCONST_STRICT;
8100 Perl_ck_repeat(pTHX_ OP *o)
8102 PERL_ARGS_ASSERT_CK_REPEAT;
8104 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8105 o->op_private |= OPpREPEAT_DOLIST;
8106 cBINOPo->op_first = force_list(cBINOPo->op_first);
8114 Perl_ck_require(pTHX_ OP *o)
8119 PERL_ARGS_ASSERT_CK_REQUIRE;
8121 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8122 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8124 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8125 SV * const sv = kid->op_sv;
8126 U32 was_readonly = SvREADONLY(sv);
8133 sv_force_normal_flags(sv, 0);
8134 assert(!SvREADONLY(sv));
8144 for (; s < end; s++) {
8145 if (*s == ':' && s[1] == ':') {
8147 Move(s+2, s+1, end - s - 1, char);
8152 sv_catpvs(sv, ".pm");
8153 SvFLAGS(sv) |= was_readonly;
8157 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8158 /* handle override, if any */
8159 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8160 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8161 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8162 gv = gvp ? *gvp : NULL;
8166 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8167 OP * const kid = cUNOPo->op_first;
8170 cUNOPo->op_first = 0;
8174 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8175 op_append_elem(OP_LIST, kid,
8176 scalar(newUNOP(OP_RV2CV, 0,
8179 op_getmad(o,newop,'O');
8183 return scalar(ck_fun(o));
8187 Perl_ck_return(pTHX_ OP *o)
8192 PERL_ARGS_ASSERT_CK_RETURN;
8194 kid = cLISTOPo->op_first->op_sibling;
8195 if (CvLVALUE(PL_compcv)) {
8196 for (; kid; kid = kid->op_sibling)
8197 op_lvalue(kid, OP_LEAVESUBLV);
8199 for (; kid; kid = kid->op_sibling)
8200 if ((kid->op_type == OP_NULL)
8201 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8202 /* This is a do block */
8203 OP *op = kUNOP->op_first;
8204 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8205 op = cUNOPx(op)->op_first;
8206 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8207 /* Force the use of the caller's context */
8208 op->op_flags |= OPf_SPECIAL;
8217 Perl_ck_select(pTHX_ OP *o)
8222 PERL_ARGS_ASSERT_CK_SELECT;
8224 if (o->op_flags & OPf_KIDS) {
8225 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8226 if (kid && kid->op_sibling) {
8227 o->op_type = OP_SSELECT;
8228 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8230 return fold_constants(o);
8234 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8235 if (kid && kid->op_type == OP_RV2GV)
8236 kid->op_private &= ~HINT_STRICT_REFS;
8241 Perl_ck_shift(pTHX_ OP *o)
8244 const I32 type = o->op_type;
8246 PERL_ARGS_ASSERT_CK_SHIFT;
8248 if (!(o->op_flags & OPf_KIDS)) {
8251 if (!CvUNIQUE(PL_compcv)) {
8252 o->op_flags |= OPf_SPECIAL;
8256 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8259 OP * const oldo = o;
8260 o = newUNOP(type, 0, scalar(argop));
8261 op_getmad(oldo,o,'O');
8266 return newUNOP(type, 0, scalar(argop));
8269 return scalar(modkids(ck_push(o), type));
8273 Perl_ck_sort(pTHX_ OP *o)
8278 PERL_ARGS_ASSERT_CK_SORT;
8280 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8281 HV * const hinthv = GvHV(PL_hintgv);
8283 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8285 const I32 sorthints = (I32)SvIV(*svp);
8286 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8287 o->op_private |= OPpSORT_QSORT;
8288 if ((sorthints & HINT_SORT_STABLE) != 0)
8289 o->op_private |= OPpSORT_STABLE;
8294 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8296 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8297 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8299 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8301 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8303 if (kid->op_type == OP_SCOPE) {
8307 else if (kid->op_type == OP_LEAVE) {
8308 if (o->op_type == OP_SORT) {
8309 op_null(kid); /* wipe out leave */
8312 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8313 if (k->op_next == kid)
8315 /* don't descend into loops */
8316 else if (k->op_type == OP_ENTERLOOP
8317 || k->op_type == OP_ENTERITER)
8319 k = cLOOPx(k)->op_lastop;
8324 kid->op_next = 0; /* just disconnect the leave */
8325 k = kLISTOP->op_first;
8330 if (o->op_type == OP_SORT) {
8331 /* provide scalar context for comparison function/block */
8337 o->op_flags |= OPf_SPECIAL;
8339 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8342 firstkid = firstkid->op_sibling;
8345 /* provide list context for arguments */
8346 if (o->op_type == OP_SORT)
8353 S_simplify_sort(pTHX_ OP *o)
8356 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8362 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8364 if (!(o->op_flags & OPf_STACKED))
8366 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8367 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8368 kid = kUNOP->op_first; /* get past null */
8369 if (kid->op_type != OP_SCOPE)
8371 kid = kLISTOP->op_last; /* get past scope */
8372 switch(kid->op_type) {
8380 k = kid; /* remember this node*/
8381 if (kBINOP->op_first->op_type != OP_RV2SV)
8383 kid = kBINOP->op_first; /* get past cmp */
8384 if (kUNOP->op_first->op_type != OP_GV)
8386 kid = kUNOP->op_first; /* get past rv2sv */
8388 if (GvSTASH(gv) != PL_curstash)
8390 gvname = GvNAME(gv);
8391 if (*gvname == 'a' && gvname[1] == '\0')
8393 else if (*gvname == 'b' && gvname[1] == '\0')
8398 kid = k; /* back to cmp */
8399 if (kBINOP->op_last->op_type != OP_RV2SV)
8401 kid = kBINOP->op_last; /* down to 2nd arg */
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);
8410 ? !(*gvname == 'a' && gvname[1] == '\0')
8411 : !(*gvname == 'b' && gvname[1] == '\0'))
8413 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8415 o->op_private |= OPpSORT_DESCEND;
8416 if (k->op_type == OP_NCMP)
8417 o->op_private |= OPpSORT_NUMERIC;
8418 if (k->op_type == OP_I_NCMP)
8419 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8420 kid = cLISTOPo->op_first->op_sibling;
8421 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8423 op_getmad(kid,o,'S'); /* then delete it */
8425 op_free(kid); /* then delete it */
8430 Perl_ck_split(pTHX_ OP *o)
8435 PERL_ARGS_ASSERT_CK_SPLIT;
8437 if (o->op_flags & OPf_STACKED)
8438 return no_fh_allowed(o);
8440 kid = cLISTOPo->op_first;
8441 if (kid->op_type != OP_NULL)
8442 Perl_croak(aTHX_ "panic: ck_split");
8443 kid = kid->op_sibling;
8444 op_free(cLISTOPo->op_first);
8445 cLISTOPo->op_first = kid;
8447 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8448 cLISTOPo->op_last = kid; /* There was only one element previously */
8451 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8452 OP * const sibl = kid->op_sibling;
8453 kid->op_sibling = 0;
8454 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8455 if (cLISTOPo->op_first == cLISTOPo->op_last)
8456 cLISTOPo->op_last = kid;
8457 cLISTOPo->op_first = kid;
8458 kid->op_sibling = sibl;
8461 kid->op_type = OP_PUSHRE;
8462 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8464 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8465 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8466 "Use of /g modifier is meaningless in split");
8469 if (!kid->op_sibling)
8470 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8472 kid = kid->op_sibling;
8475 if (!kid->op_sibling)
8476 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8477 assert(kid->op_sibling);
8479 kid = kid->op_sibling;
8482 if (kid->op_sibling)
8483 return too_many_arguments(o,OP_DESC(o));
8489 Perl_ck_join(pTHX_ OP *o)
8491 const OP * const kid = cLISTOPo->op_first->op_sibling;
8493 PERL_ARGS_ASSERT_CK_JOIN;
8495 if (kid && kid->op_type == OP_MATCH) {
8496 if (ckWARN(WARN_SYNTAX)) {
8497 const REGEXP *re = PM_GETRE(kPMOP);
8498 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8499 const STRLEN len = re ? RX_PRELEN(re) : 6;
8500 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8501 "/%.*s/ should probably be written as \"%.*s\"",
8502 (int)len, pmstr, (int)len, pmstr);
8509 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8511 Examines an op, which is expected to identify a subroutine at runtime,
8512 and attempts to determine at compile time which subroutine it identifies.
8513 This is normally used during Perl compilation to determine whether
8514 a prototype can be applied to a function call. I<cvop> is the op
8515 being considered, normally an C<rv2cv> op. A pointer to the identified
8516 subroutine is returned, if it could be determined statically, and a null
8517 pointer is returned if it was not possible to determine statically.
8519 Currently, the subroutine can be identified statically if the RV that the
8520 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8521 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8522 suitable if the constant value must be an RV pointing to a CV. Details of
8523 this process may change in future versions of Perl. If the C<rv2cv> op
8524 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8525 the subroutine statically: this flag is used to suppress compile-time
8526 magic on a subroutine call, forcing it to use default runtime behaviour.
8528 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8529 of a GV reference is modified. If a GV was examined and its CV slot was
8530 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8531 If the op is not optimised away, and the CV slot is later populated with
8532 a subroutine having a prototype, that flag eventually triggers the warning
8533 "called too early to check prototype".
8535 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8536 of returning a pointer to the subroutine it returns a pointer to the
8537 GV giving the most appropriate name for the subroutine in this context.
8538 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8539 (C<CvANON>) subroutine that is referenced through a GV it will be the
8540 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8541 A null pointer is returned as usual if there is no statically-determinable
8548 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8553 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8554 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8555 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8556 if (cvop->op_type != OP_RV2CV)
8558 if (cvop->op_private & OPpENTERSUB_AMPER)
8560 if (!(cvop->op_flags & OPf_KIDS))
8562 rvop = cUNOPx(cvop)->op_first;
8563 switch (rvop->op_type) {
8565 gv = cGVOPx_gv(rvop);
8568 if (flags & RV2CVOPCV_MARK_EARLY)
8569 rvop->op_private |= OPpEARLY_CV;
8574 SV *rv = cSVOPx_sv(rvop);
8584 if (SvTYPE((SV*)cv) != SVt_PVCV)
8586 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8587 if (!CvANON(cv) || !gv)
8596 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8598 Performs the default fixup of the arguments part of an C<entersub>
8599 op tree. This consists of applying list context to each of the
8600 argument ops. This is the standard treatment used on a call marked
8601 with C<&>, or a method call, or a call through a subroutine reference,
8602 or any other call where the callee can't be identified at compile time,
8603 or a call where the callee has no prototype.
8609 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8612 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8613 aop = cUNOPx(entersubop)->op_first;
8614 if (!aop->op_sibling)
8615 aop = cUNOPx(aop)->op_first;
8616 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8617 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8619 op_lvalue(aop, OP_ENTERSUB);
8626 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8628 Performs the fixup of the arguments part of an C<entersub> op tree
8629 based on a subroutine prototype. This makes various modifications to
8630 the argument ops, from applying context up to inserting C<refgen> ops,
8631 and checking the number and syntactic types of arguments, as directed by
8632 the prototype. This is the standard treatment used on a subroutine call,
8633 not marked with C<&>, where the callee can be identified at compile time
8634 and has a prototype.
8636 I<protosv> supplies the subroutine prototype to be applied to the call.
8637 It may be a normal defined scalar, of which the string value will be used.
8638 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8639 that has been cast to C<SV*>) which has a prototype. The prototype
8640 supplied, in whichever form, does not need to match the actual callee
8641 referenced by the op tree.
8643 If the argument ops disagree with the prototype, for example by having
8644 an unacceptable number of arguments, a valid op tree is returned anyway.
8645 The error is reflected in the parser state, normally resulting in a single
8646 exception at the top level of parsing which covers all the compilation
8647 errors that occurred. In the error message, the callee is referred to
8648 by the name defined by the I<namegv> parameter.
8654 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8657 const char *proto, *proto_end;
8658 OP *aop, *prev, *cvop;
8661 I32 contextclass = 0;
8662 const char *e = NULL;
8663 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8664 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8665 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8666 proto = SvPV(protosv, proto_len);
8667 proto_end = proto + proto_len;
8668 aop = cUNOPx(entersubop)->op_first;
8669 if (!aop->op_sibling)
8670 aop = cUNOPx(aop)->op_first;
8672 aop = aop->op_sibling;
8673 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8674 while (aop != cvop) {
8676 if (PL_madskills && aop->op_type == OP_STUB) {
8677 aop = aop->op_sibling;
8680 if (PL_madskills && aop->op_type == OP_NULL)
8681 o3 = ((UNOP*)aop)->op_first;
8685 if (proto >= proto_end)
8686 return too_many_arguments(entersubop, gv_ename(namegv));
8694 /* _ must be at the end */
8695 if (proto[1] && proto[1] != ';')
8710 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8712 arg == 1 ? "block or sub {}" : "sub {}",
8713 gv_ename(namegv), o3);
8716 /* '*' allows any scalar type, including bareword */
8719 if (o3->op_type == OP_RV2GV)
8720 goto wrapref; /* autoconvert GLOB -> GLOBref */
8721 else if (o3->op_type == OP_CONST)
8722 o3->op_private &= ~OPpCONST_STRICT;
8723 else if (o3->op_type == OP_ENTERSUB) {
8724 /* accidental subroutine, revert to bareword */
8725 OP *gvop = ((UNOP*)o3)->op_first;
8726 if (gvop && gvop->op_type == OP_NULL) {
8727 gvop = ((UNOP*)gvop)->op_first;
8729 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8732 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8733 (gvop = ((UNOP*)gvop)->op_first) &&
8734 gvop->op_type == OP_GV)
8736 GV * const gv = cGVOPx_gv(gvop);
8737 OP * const sibling = aop->op_sibling;
8738 SV * const n = newSVpvs("");
8740 OP * const oldaop = aop;
8744 gv_fullname4(n, gv, "", FALSE);
8745 aop = newSVOP(OP_CONST, 0, n);
8746 op_getmad(oldaop,aop,'O');
8747 prev->op_sibling = aop;
8748 aop->op_sibling = sibling;
8758 if (o3->op_type == OP_RV2AV ||
8759 o3->op_type == OP_PADAV ||
8760 o3->op_type == OP_RV2HV ||
8761 o3->op_type == OP_PADHV
8776 if (contextclass++ == 0) {
8777 e = strchr(proto, ']');
8778 if (!e || e == proto)
8787 const char *p = proto;
8788 const char *const end = proto;
8790 while (*--p != '[') {}
8791 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8793 gv_ename(namegv), o3);
8798 if (o3->op_type == OP_RV2GV)
8801 bad_type(arg, "symbol", gv_ename(namegv), o3);
8804 if (o3->op_type == OP_ENTERSUB)
8807 bad_type(arg, "subroutine entry", gv_ename(namegv),
8811 if (o3->op_type == OP_RV2SV ||
8812 o3->op_type == OP_PADSV ||
8813 o3->op_type == OP_HELEM ||
8814 o3->op_type == OP_AELEM)
8817 bad_type(arg, "scalar", gv_ename(namegv), o3);
8820 if (o3->op_type == OP_RV2AV ||
8821 o3->op_type == OP_PADAV)
8824 bad_type(arg, "array", gv_ename(namegv), o3);
8827 if (o3->op_type == OP_RV2HV ||
8828 o3->op_type == OP_PADHV)
8831 bad_type(arg, "hash", gv_ename(namegv), o3);
8835 OP* const kid = aop;
8836 OP* const sib = kid->op_sibling;
8837 kid->op_sibling = 0;
8838 aop = newUNOP(OP_REFGEN, 0, kid);
8839 aop->op_sibling = sib;
8840 prev->op_sibling = aop;
8842 if (contextclass && e) {
8857 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8858 gv_ename(namegv), SVfARG(protosv));
8861 op_lvalue(aop, OP_ENTERSUB);
8863 aop = aop->op_sibling;
8865 if (aop == cvop && *proto == '_') {
8866 /* generate an access to $_ */
8868 aop->op_sibling = prev->op_sibling;
8869 prev->op_sibling = aop; /* instead of cvop */
8871 if (!optional && proto_end > proto &&
8872 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8873 return too_few_arguments(entersubop, gv_ename(namegv));
8878 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8880 Performs the fixup of the arguments part of an C<entersub> op tree either
8881 based on a subroutine prototype or using default list-context processing.
8882 This is the standard treatment used on a subroutine call, not marked
8883 with C<&>, where the callee can be identified at compile time.
8885 I<protosv> supplies the subroutine prototype to be applied to the call,
8886 or indicates that there is no prototype. It may be a normal scalar,
8887 in which case if it is defined then the string value will be used
8888 as a prototype, and if it is undefined then there is no prototype.
8889 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8890 that has been cast to C<SV*>), of which the prototype will be used if it
8891 has one. The prototype (or lack thereof) supplied, in whichever form,
8892 does not need to match the actual callee referenced by the op tree.
8894 If the argument ops disagree with the prototype, for example by having
8895 an unacceptable number of arguments, a valid op tree is returned anyway.
8896 The error is reflected in the parser state, normally resulting in a single
8897 exception at the top level of parsing which covers all the compilation
8898 errors that occurred. In the error message, the callee is referred to
8899 by the name defined by the I<namegv> parameter.
8905 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8906 GV *namegv, SV *protosv)
8908 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8909 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8910 return ck_entersub_args_proto(entersubop, namegv, protosv);
8912 return ck_entersub_args_list(entersubop);
8916 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8918 Retrieves the function that will be used to fix up a call to I<cv>.
8919 Specifically, the function is applied to an C<entersub> op tree for a
8920 subroutine call, not marked with C<&>, where the callee can be identified
8921 at compile time as I<cv>.
8923 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8924 argument for it is returned in I<*ckobj_p>. The function is intended
8925 to be called in this manner:
8927 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8929 In this call, I<entersubop> is a pointer to the C<entersub> op,
8930 which may be replaced by the check function, and I<namegv> is a GV
8931 supplying the name that should be used by the check function to refer
8932 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8933 It is permitted to apply the check function in non-standard situations,
8934 such as to a call to a different subroutine or to a method call.
8936 By default, the function is
8937 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8938 and the SV parameter is I<cv> itself. This implements standard
8939 prototype processing. It can be changed, for a particular subroutine,
8940 by L</cv_set_call_checker>.
8946 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8949 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8950 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8952 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8953 *ckobj_p = callmg->mg_obj;
8955 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8961 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8963 Sets the function that will be used to fix up a call to I<cv>.
8964 Specifically, the function is applied to an C<entersub> op tree for a
8965 subroutine call, not marked with C<&>, where the callee can be identified
8966 at compile time as I<cv>.
8968 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8969 for it is supplied in I<ckobj>. The function is intended to be called
8972 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8974 In this call, I<entersubop> is a pointer to the C<entersub> op,
8975 which may be replaced by the check function, and I<namegv> is a GV
8976 supplying the name that should be used by the check function to refer
8977 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8978 It is permitted to apply the check function in non-standard situations,
8979 such as to a call to a different subroutine or to a method call.
8981 The current setting for a particular CV can be retrieved by
8982 L</cv_get_call_checker>.
8988 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8990 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8991 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8992 if (SvMAGICAL((SV*)cv))
8993 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8996 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8997 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8998 if (callmg->mg_flags & MGf_REFCOUNTED) {
8999 SvREFCNT_dec(callmg->mg_obj);
9000 callmg->mg_flags &= ~MGf_REFCOUNTED;
9002 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9003 callmg->mg_obj = ckobj;
9004 if (ckobj != (SV*)cv) {
9005 SvREFCNT_inc_simple_void_NN(ckobj);
9006 callmg->mg_flags |= MGf_REFCOUNTED;
9012 Perl_ck_subr(pTHX_ OP *o)
9018 PERL_ARGS_ASSERT_CK_SUBR;
9020 aop = cUNOPx(o)->op_first;
9021 if (!aop->op_sibling)
9022 aop = cUNOPx(aop)->op_first;
9023 aop = aop->op_sibling;
9024 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9025 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9026 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9028 o->op_private |= OPpENTERSUB_HASTARG;
9029 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9030 if (PERLDB_SUB && PL_curstash != PL_debstash)
9031 o->op_private |= OPpENTERSUB_DB;
9032 if (cvop->op_type == OP_RV2CV) {
9033 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9035 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9036 if (aop->op_type == OP_CONST)
9037 aop->op_private &= ~OPpCONST_STRICT;
9038 else if (aop->op_type == OP_LIST) {
9039 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9040 if (sib && sib->op_type == OP_CONST)
9041 sib->op_private &= ~OPpCONST_STRICT;
9046 return ck_entersub_args_list(o);
9048 Perl_call_checker ckfun;
9050 cv_get_call_checker(cv, &ckfun, &ckobj);
9051 return ckfun(aTHX_ o, namegv, ckobj);
9056 Perl_ck_svconst(pTHX_ OP *o)
9058 PERL_ARGS_ASSERT_CK_SVCONST;
9059 PERL_UNUSED_CONTEXT;
9060 SvREADONLY_on(cSVOPo->op_sv);
9065 Perl_ck_chdir(pTHX_ OP *o)
9067 PERL_ARGS_ASSERT_CK_CHDIR;
9068 if (o->op_flags & OPf_KIDS) {
9069 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9071 if (kid && kid->op_type == OP_CONST &&
9072 (kid->op_private & OPpCONST_BARE))
9074 o->op_flags |= OPf_SPECIAL;
9075 kid->op_private &= ~OPpCONST_STRICT;
9082 Perl_ck_trunc(pTHX_ OP *o)
9084 PERL_ARGS_ASSERT_CK_TRUNC;
9086 if (o->op_flags & OPf_KIDS) {
9087 SVOP *kid = (SVOP*)cUNOPo->op_first;
9089 if (kid->op_type == OP_NULL)
9090 kid = (SVOP*)kid->op_sibling;
9091 if (kid && kid->op_type == OP_CONST &&
9092 (kid->op_private & OPpCONST_BARE))
9094 o->op_flags |= OPf_SPECIAL;
9095 kid->op_private &= ~OPpCONST_STRICT;
9102 Perl_ck_unpack(pTHX_ OP *o)
9104 OP *kid = cLISTOPo->op_first;
9106 PERL_ARGS_ASSERT_CK_UNPACK;
9108 if (kid->op_sibling) {
9109 kid = kid->op_sibling;
9110 if (!kid->op_sibling)
9111 kid->op_sibling = newDEFSVOP();
9117 Perl_ck_substr(pTHX_ OP *o)
9119 PERL_ARGS_ASSERT_CK_SUBSTR;
9122 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9123 OP *kid = cLISTOPo->op_first;
9125 if (kid->op_type == OP_NULL)
9126 kid = kid->op_sibling;
9128 kid->op_flags |= OPf_MOD;
9135 Perl_ck_push(pTHX_ OP *o)
9138 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9142 PERL_ARGS_ASSERT_CK_PUSH;
9144 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9146 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9149 /* If not array or array deref, wrap it with an array deref.
9150 * For OP_CONST, we only wrap arrayrefs */
9152 if ( ( cursor->op_type != OP_PADAV
9153 && cursor->op_type != OP_RV2AV
9154 && cursor->op_type != OP_CONST
9157 ( cursor->op_type == OP_CONST
9158 && SvROK(cSVOPx_sv(cursor))
9159 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9162 proxy = newAVREF(cursor);
9163 if ( cursor == kid ) {
9164 cLISTOPx(o)->op_first = proxy;
9167 cLISTOPx(kid)->op_sibling = proxy;
9169 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9170 cLISTOPx(cursor)->op_sibling = NULL;
9177 Perl_ck_each(pTHX_ OP *o)
9180 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9181 const unsigned orig_type = o->op_type;
9182 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9183 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9184 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9185 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9187 PERL_ARGS_ASSERT_CK_EACH;
9190 switch (kid->op_type) {
9196 CHANGE_TYPE(o, array_type);
9199 if (kid->op_private == OPpCONST_BARE)
9200 /* we let ck_fun treat as hash */
9203 CHANGE_TYPE(o, ref_type);
9206 /* if treating as a reference, defer additional checks to runtime */
9207 return o->op_type == ref_type ? o : ck_fun(o);
9210 /* caller is supposed to assign the return to the
9211 container of the rep_op var */
9213 S_opt_scalarhv(pTHX_ OP *rep_op) {
9217 PERL_ARGS_ASSERT_OPT_SCALARHV;
9219 NewOp(1101, unop, 1, UNOP);
9220 unop->op_type = (OPCODE)OP_BOOLKEYS;
9221 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9222 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9223 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9224 unop->op_first = rep_op;
9225 unop->op_next = rep_op->op_next;
9226 rep_op->op_next = (OP*)unop;
9227 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9228 unop->op_sibling = rep_op->op_sibling;
9229 rep_op->op_sibling = NULL;
9230 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9231 if (rep_op->op_type == OP_PADHV) {
9232 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9233 rep_op->op_flags |= OPf_WANT_LIST;
9238 /* Checks if o acts as an in-place operator on an array. oright points to the
9239 * beginning of the right-hand side. Returns the left-hand side of the
9240 * assignment if o acts in-place, or NULL otherwise. */
9243 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9247 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9250 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9251 || oright->op_next != o
9252 || (oright->op_private & OPpLVAL_INTRO)
9256 /* o2 follows the chain of op_nexts through the LHS of the
9257 * assign (if any) to the aassign op itself */
9259 if (!o2 || o2->op_type != OP_NULL)
9262 if (!o2 || o2->op_type != OP_PUSHMARK)
9265 if (o2 && o2->op_type == OP_GV)
9268 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9269 || (o2->op_private & OPpLVAL_INTRO)
9274 if (!o2 || o2->op_type != OP_NULL)
9277 if (!o2 || o2->op_type != OP_AASSIGN
9278 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9281 /* check that the sort is the first arg on RHS of assign */
9283 o2 = cUNOPx(o2)->op_first;
9284 if (!o2 || o2->op_type != OP_NULL)
9286 o2 = cUNOPx(o2)->op_first;
9287 if (!o2 || o2->op_type != OP_PUSHMARK)
9289 if (o2->op_sibling != o)
9292 /* check the array is the same on both sides */
9293 if (oleft->op_type == OP_RV2AV) {
9294 if (oright->op_type != OP_RV2AV
9295 || !cUNOPx(oright)->op_first
9296 || cUNOPx(oright)->op_first->op_type != OP_GV
9297 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9298 cGVOPx_gv(cUNOPx(oright)->op_first)
9302 else if (oright->op_type != OP_PADAV
9303 || oright->op_targ != oleft->op_targ
9310 /* A peephole optimizer. We visit the ops in the order they're to execute.
9311 * See the comments at the top of this file for more details about when
9312 * peep() is called */
9315 Perl_rpeep(pTHX_ register OP *o)
9318 register OP* oldop = NULL;
9320 if (!o || o->op_opt)
9324 SAVEVPTR(PL_curcop);
9325 for (; o; o = o->op_next) {
9328 /* By default, this op has now been optimised. A couple of cases below
9329 clear this again. */
9332 switch (o->op_type) {
9334 PL_curcop = ((COP*)o); /* for warnings */
9337 PL_curcop = ((COP*)o); /* for warnings */
9339 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9340 to carry two labels. For now, take the easier option, and skip
9341 this optimisation if the first NEXTSTATE has a label. */
9342 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9343 OP *nextop = o->op_next;
9344 while (nextop && nextop->op_type == OP_NULL)
9345 nextop = nextop->op_next;
9347 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9348 COP *firstcop = (COP *)o;
9349 COP *secondcop = (COP *)nextop;
9350 /* We want the COP pointed to by o (and anything else) to
9351 become the next COP down the line. */
9354 firstcop->op_next = secondcop->op_next;
9356 /* Now steal all its pointers, and duplicate the other
9358 firstcop->cop_line = secondcop->cop_line;
9360 firstcop->cop_stashpv = secondcop->cop_stashpv;
9361 firstcop->cop_file = secondcop->cop_file;
9363 firstcop->cop_stash = secondcop->cop_stash;
9364 firstcop->cop_filegv = secondcop->cop_filegv;
9366 firstcop->cop_hints = secondcop->cop_hints;
9367 firstcop->cop_seq = secondcop->cop_seq;
9368 firstcop->cop_warnings = secondcop->cop_warnings;
9369 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9372 secondcop->cop_stashpv = NULL;
9373 secondcop->cop_file = NULL;
9375 secondcop->cop_stash = NULL;
9376 secondcop->cop_filegv = NULL;
9378 secondcop->cop_warnings = NULL;
9379 secondcop->cop_hints_hash = NULL;
9381 /* If we use op_null(), and hence leave an ex-COP, some
9382 warnings are misreported. For example, the compile-time
9383 error in 'use strict; no strict refs;' */
9384 secondcop->op_type = OP_NULL;
9385 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9391 if (cSVOPo->op_private & OPpCONST_STRICT)
9392 no_bareword_allowed(o);
9395 case OP_METHOD_NAMED:
9396 /* Relocate sv to the pad for thread safety.
9397 * Despite being a "constant", the SV is written to,
9398 * for reference counts, sv_upgrade() etc. */
9400 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9401 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9402 /* If op_sv is already a PADTMP then it is being used by
9403 * some pad, so make a copy. */
9404 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9405 SvREADONLY_on(PAD_SVl(ix));
9406 SvREFCNT_dec(cSVOPo->op_sv);
9408 else if (o->op_type != OP_METHOD_NAMED
9409 && cSVOPo->op_sv == &PL_sv_undef) {
9410 /* PL_sv_undef is hack - it's unsafe to store it in the
9411 AV that is the pad, because av_fetch treats values of
9412 PL_sv_undef as a "free" AV entry and will merrily
9413 replace them with a new SV, causing pad_alloc to think
9414 that this pad slot is free. (When, clearly, it is not)
9416 SvOK_off(PAD_SVl(ix));
9417 SvPADTMP_on(PAD_SVl(ix));
9418 SvREADONLY_on(PAD_SVl(ix));
9421 SvREFCNT_dec(PAD_SVl(ix));
9422 SvPADTMP_on(cSVOPo->op_sv);
9423 PAD_SETSV(ix, cSVOPo->op_sv);
9424 /* XXX I don't know how this isn't readonly already. */
9425 SvREADONLY_on(PAD_SVl(ix));
9427 cSVOPo->op_sv = NULL;
9434 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9435 if (o->op_next->op_private & OPpTARGET_MY) {
9436 if (o->op_flags & OPf_STACKED) /* chained concats */
9437 break; /* ignore_optimization */
9439 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9440 o->op_targ = o->op_next->op_targ;
9441 o->op_next->op_targ = 0;
9442 o->op_private |= OPpTARGET_MY;
9445 op_null(o->op_next);
9449 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9450 break; /* Scalar stub must produce undef. List stub is noop */
9454 if (o->op_targ == OP_NEXTSTATE
9455 || o->op_targ == OP_DBSTATE)
9457 PL_curcop = ((COP*)o);
9459 /* XXX: We avoid setting op_seq here to prevent later calls
9460 to rpeep() from mistakenly concluding that optimisation
9461 has already occurred. This doesn't fix the real problem,
9462 though (See 20010220.007). AMS 20010719 */
9463 /* op_seq functionality is now replaced by op_opt */
9470 if (oldop && o->op_next) {
9471 oldop->op_next = o->op_next;
9479 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9480 OP* const pop = (o->op_type == OP_PADAV) ?
9481 o->op_next : o->op_next->op_next;
9483 if (pop && pop->op_type == OP_CONST &&
9484 ((PL_op = pop->op_next)) &&
9485 pop->op_next->op_type == OP_AELEM &&
9486 !(pop->op_next->op_private &
9487 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9488 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9493 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9494 no_bareword_allowed(pop);
9495 if (o->op_type == OP_GV)
9496 op_null(o->op_next);
9497 op_null(pop->op_next);
9499 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9500 o->op_next = pop->op_next->op_next;
9501 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9502 o->op_private = (U8)i;
9503 if (o->op_type == OP_GV) {
9508 o->op_flags |= OPf_SPECIAL;
9509 o->op_type = OP_AELEMFAST;
9514 if (o->op_next->op_type == OP_RV2SV) {
9515 if (!(o->op_next->op_private & OPpDEREF)) {
9516 op_null(o->op_next);
9517 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9519 o->op_next = o->op_next->op_next;
9520 o->op_type = OP_GVSV;
9521 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9524 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9525 GV * const gv = cGVOPo_gv;
9526 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9527 /* XXX could check prototype here instead of just carping */
9528 SV * const sv = sv_newmortal();
9529 gv_efullname3(sv, gv, NULL);
9530 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9531 "%"SVf"() called too early to check prototype",
9535 else if (o->op_next->op_type == OP_READLINE
9536 && o->op_next->op_next->op_type == OP_CONCAT
9537 && (o->op_next->op_next->op_flags & OPf_STACKED))
9539 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9540 o->op_type = OP_RCATLINE;
9541 o->op_flags |= OPf_STACKED;
9542 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9543 op_null(o->op_next->op_next);
9544 op_null(o->op_next);
9554 fop = cUNOP->op_first;
9562 fop = cLOGOP->op_first;
9563 sop = fop->op_sibling;
9564 while (cLOGOP->op_other->op_type == OP_NULL)
9565 cLOGOP->op_other = cLOGOP->op_other->op_next;
9566 CALL_RPEEP(cLOGOP->op_other);
9570 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9572 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9577 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9578 while (nop && nop->op_next) {
9579 switch (nop->op_next->op_type) {
9584 lop = nop = nop->op_next;
9595 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9596 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9597 cLOGOP->op_first = opt_scalarhv(fop);
9598 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9599 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9615 while (cLOGOP->op_other->op_type == OP_NULL)
9616 cLOGOP->op_other = cLOGOP->op_other->op_next;
9617 CALL_RPEEP(cLOGOP->op_other);
9622 while (cLOOP->op_redoop->op_type == OP_NULL)
9623 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9624 CALL_RPEEP(cLOOP->op_redoop);
9625 while (cLOOP->op_nextop->op_type == OP_NULL)
9626 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9627 CALL_RPEEP(cLOOP->op_nextop);
9628 while (cLOOP->op_lastop->op_type == OP_NULL)
9629 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9630 CALL_RPEEP(cLOOP->op_lastop);
9634 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9635 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9636 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9637 cPMOP->op_pmstashstartu.op_pmreplstart
9638 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9639 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9643 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9644 && ckWARN(WARN_SYNTAX))
9646 if (o->op_next->op_sibling) {
9647 const OPCODE type = o->op_next->op_sibling->op_type;
9648 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9649 const line_t oldline = CopLINE(PL_curcop);
9650 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9651 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9652 "Statement unlikely to be reached");
9653 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9654 "\t(Maybe you meant system() when you said exec()?)\n");
9655 CopLINE_set(PL_curcop, oldline);
9666 const char *key = NULL;
9669 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9672 /* Make the CONST have a shared SV */
9673 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9674 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9675 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9676 key = SvPV_const(sv, keylen);
9677 lexname = newSVpvn_share(key,
9678 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9684 if ((o->op_private & (OPpLVAL_INTRO)))
9687 rop = (UNOP*)((BINOP*)o)->op_first;
9688 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9690 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9691 if (!SvPAD_TYPED(lexname))
9693 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9694 if (!fields || !GvHV(*fields))
9696 key = SvPV_const(*svp, keylen);
9697 if (!hv_fetch(GvHV(*fields), key,
9698 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9700 Perl_croak(aTHX_ "No such class field \"%s\" "
9701 "in variable %s of type %s",
9702 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9715 SVOP *first_key_op, *key_op;
9717 if ((o->op_private & (OPpLVAL_INTRO))
9718 /* I bet there's always a pushmark... */
9719 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9720 /* hmmm, no optimization if list contains only one key. */
9722 rop = (UNOP*)((LISTOP*)o)->op_last;
9723 if (rop->op_type != OP_RV2HV)
9725 if (rop->op_first->op_type == OP_PADSV)
9726 /* @$hash{qw(keys here)} */
9727 rop = (UNOP*)rop->op_first;
9729 /* @{$hash}{qw(keys here)} */
9730 if (rop->op_first->op_type == OP_SCOPE
9731 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9733 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9739 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9740 if (!SvPAD_TYPED(lexname))
9742 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9743 if (!fields || !GvHV(*fields))
9745 /* Again guessing that the pushmark can be jumped over.... */
9746 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9747 ->op_first->op_sibling;
9748 for (key_op = first_key_op; key_op;
9749 key_op = (SVOP*)key_op->op_sibling) {
9750 if (key_op->op_type != OP_CONST)
9752 svp = cSVOPx_svp(key_op);
9753 key = SvPV_const(*svp, keylen);
9754 if (!hv_fetch(GvHV(*fields), key,
9755 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9757 Perl_croak(aTHX_ "No such class field \"%s\" "
9758 "in variable %s of type %s",
9759 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9768 && ( oldop->op_type == OP_AELEM
9769 || oldop->op_type == OP_PADSV
9770 || oldop->op_type == OP_RV2SV
9771 || oldop->op_type == OP_RV2GV
9772 || oldop->op_type == OP_HELEM
9774 && (oldop->op_private & OPpDEREF)
9776 o->op_private |= OPpDEREFed;
9780 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9784 /* check that RHS of sort is a single plain array */
9785 OP *oright = cUNOPo->op_first;
9786 if (!oright || oright->op_type != OP_PUSHMARK)
9789 /* reverse sort ... can be optimised. */
9790 if (!cUNOPo->op_sibling) {
9791 /* Nothing follows us on the list. */
9792 OP * const reverse = o->op_next;
9794 if (reverse->op_type == OP_REVERSE &&
9795 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9796 OP * const pushmark = cUNOPx(reverse)->op_first;
9797 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9798 && (cUNOPx(pushmark)->op_sibling == o)) {
9799 /* reverse -> pushmark -> sort */
9800 o->op_private |= OPpSORT_REVERSE;
9802 pushmark->op_next = oright->op_next;
9808 /* make @a = sort @a act in-place */
9810 oright = cUNOPx(oright)->op_sibling;
9813 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9814 oright = cUNOPx(oright)->op_sibling;
9817 oleft = is_inplace_av(o, oright);
9821 /* transfer MODishness etc from LHS arg to RHS arg */
9822 oright->op_flags = oleft->op_flags;
9823 o->op_private |= OPpSORT_INPLACE;
9825 /* excise push->gv->rv2av->null->aassign */
9826 o2 = o->op_next->op_next;
9827 op_null(o2); /* PUSHMARK */
9829 if (o2->op_type == OP_GV) {
9830 op_null(o2); /* GV */
9833 op_null(o2); /* RV2AV or PADAV */
9834 o2 = o2->op_next->op_next;
9835 op_null(o2); /* AASSIGN */
9837 o->op_next = o2->op_next;
9843 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9846 LISTOP *enter, *exlist;
9848 /* @a = reverse @a */
9849 if ((oright = cLISTOPo->op_first)
9850 && (oright->op_type == OP_PUSHMARK)
9851 && (oright = oright->op_sibling)
9852 && (oleft = is_inplace_av(o, oright))) {
9855 /* transfer MODishness etc from LHS arg to RHS arg */
9856 oright->op_flags = oleft->op_flags;
9857 o->op_private |= OPpREVERSE_INPLACE;
9859 /* excise push->gv->rv2av->null->aassign */
9860 o2 = o->op_next->op_next;
9861 op_null(o2); /* PUSHMARK */
9863 if (o2->op_type == OP_GV) {
9864 op_null(o2); /* GV */
9867 op_null(o2); /* RV2AV or PADAV */
9868 o2 = o2->op_next->op_next;
9869 op_null(o2); /* AASSIGN */
9871 o->op_next = o2->op_next;
9875 enter = (LISTOP *) o->op_next;
9878 if (enter->op_type == OP_NULL) {
9879 enter = (LISTOP *) enter->op_next;
9883 /* for $a (...) will have OP_GV then OP_RV2GV here.
9884 for (...) just has an OP_GV. */
9885 if (enter->op_type == OP_GV) {
9886 gvop = (OP *) enter;
9887 enter = (LISTOP *) enter->op_next;
9890 if (enter->op_type == OP_RV2GV) {
9891 enter = (LISTOP *) enter->op_next;
9897 if (enter->op_type != OP_ENTERITER)
9900 iter = enter->op_next;
9901 if (!iter || iter->op_type != OP_ITER)
9904 expushmark = enter->op_first;
9905 if (!expushmark || expushmark->op_type != OP_NULL
9906 || expushmark->op_targ != OP_PUSHMARK)
9909 exlist = (LISTOP *) expushmark->op_sibling;
9910 if (!exlist || exlist->op_type != OP_NULL
9911 || exlist->op_targ != OP_LIST)
9914 if (exlist->op_last != o) {
9915 /* Mmm. Was expecting to point back to this op. */
9918 theirmark = exlist->op_first;
9919 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9922 if (theirmark->op_sibling != o) {
9923 /* There's something between the mark and the reverse, eg
9924 for (1, reverse (...))
9929 ourmark = ((LISTOP *)o)->op_first;
9930 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9933 ourlast = ((LISTOP *)o)->op_last;
9934 if (!ourlast || ourlast->op_next != o)
9937 rv2av = ourmark->op_sibling;
9938 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9939 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9940 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9941 /* We're just reversing a single array. */
9942 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9943 enter->op_flags |= OPf_STACKED;
9946 /* We don't have control over who points to theirmark, so sacrifice
9948 theirmark->op_next = ourmark->op_next;
9949 theirmark->op_flags = ourmark->op_flags;
9950 ourlast->op_next = gvop ? gvop : (OP *) enter;
9953 enter->op_private |= OPpITER_REVERSED;
9954 iter->op_private |= OPpITER_REVERSED;
9961 UNOP *refgen, *rv2cv;
9964 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9967 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9970 rv2gv = ((BINOP *)o)->op_last;
9971 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9974 refgen = (UNOP *)((BINOP *)o)->op_first;
9976 if (!refgen || refgen->op_type != OP_REFGEN)
9979 exlist = (LISTOP *)refgen->op_first;
9980 if (!exlist || exlist->op_type != OP_NULL
9981 || exlist->op_targ != OP_LIST)
9984 if (exlist->op_first->op_type != OP_PUSHMARK)
9987 rv2cv = (UNOP*)exlist->op_last;
9989 if (rv2cv->op_type != OP_RV2CV)
9992 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9993 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9994 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9996 o->op_private |= OPpASSIGN_CV_TO_GV;
9997 rv2gv->op_private |= OPpDONT_INIT_GV;
9998 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10006 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10007 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10012 Perl_cpeep_t cpeep =
10013 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10015 cpeep(aTHX_ o, oldop);
10026 Perl_peep(pTHX_ register OP *o)
10032 =head1 Custom Operators
10034 =for apidoc Ao||custom_op_xop
10035 Return the XOP structure for a given custom op. This function should be
10036 considered internal to OP_NAME and the other access macros: use them instead.
10042 Perl_custom_op_xop(pTHX_ const OP *o)
10048 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10050 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10051 assert(o->op_type == OP_CUSTOM);
10053 /* This is wrong. It assumes a function pointer can be cast to IV,
10054 * which isn't guaranteed, but this is what the old custom OP code
10055 * did. In principle it should be safer to Copy the bytes of the
10056 * pointer into a PV: since the new interface is hidden behind
10057 * functions, this can be changed later if necessary. */
10058 /* Change custom_op_xop if this ever happens */
10059 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10062 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10064 /* assume noone will have just registered a desc */
10065 if (!he && PL_custom_op_names &&
10066 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10071 /* XXX does all this need to be shared mem? */
10072 Newxz(xop, 1, XOP);
10073 pv = SvPV(HeVAL(he), l);
10074 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10075 if (PL_custom_op_descs &&
10076 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10078 pv = SvPV(HeVAL(he), l);
10079 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10081 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10085 if (!he) return &xop_null;
10087 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10092 =for apidoc Ao||custom_op_register
10093 Register a custom op. See L<perlguts/"Custom Operators">.
10099 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10103 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10105 /* see the comment in custom_op_xop */
10106 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10108 if (!PL_custom_ops)
10109 PL_custom_ops = newHV();
10111 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10112 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10117 /* Efficient sub that returns a constant scalar value. */
10119 const_sv_xsub(pTHX_ CV* cv)
10123 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10127 /* diag_listed_as: SKIPME */
10128 Perl_croak(aTHX_ "usage: %s::%s()",
10129 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10142 * c-indentation-style: bsd
10143 * c-basic-offset: 4
10144 * indent-tabs-mode: t
10147 * ex: set ts=8 sts=4 sw=4 noet: