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 if (ckWARN(WARN_SYNTAX)) {
915 const line_t oldline = CopLINE(PL_curcop);
917 if (PL_parser && PL_parser->copline != NOLINE)
918 CopLINE_set(PL_curcop, PL_parser->copline);
919 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
920 CopLINE_set(PL_curcop, oldline);
927 Perl_scalar(pTHX_ OP *o)
932 /* assumes no premature commitment */
933 if (!o || (PL_parser && PL_parser->error_count)
934 || (o->op_flags & OPf_WANT)
935 || o->op_type == OP_RETURN)
940 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
942 switch (o->op_type) {
944 scalar(cBINOPo->op_first);
949 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
959 if (o->op_flags & OPf_KIDS) {
960 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
966 kid = cLISTOPo->op_first;
968 kid = kid->op_sibling;
971 OP *sib = kid->op_sibling;
972 if (sib && kid->op_type != OP_LEAVEWHEN) {
973 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
983 PL_curcop = &PL_compiling;
988 kid = cLISTOPo->op_first;
991 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
998 Perl_scalarvoid(pTHX_ OP *o)
1002 const char* useless = NULL;
1006 PERL_ARGS_ASSERT_SCALARVOID;
1008 /* trailing mad null ops don't count as "there" for void processing */
1010 o->op_type != OP_NULL &&
1012 o->op_sibling->op_type == OP_NULL)
1015 for (sib = o->op_sibling;
1016 sib && sib->op_type == OP_NULL;
1017 sib = sib->op_sibling) ;
1023 if (o->op_type == OP_NEXTSTATE
1024 || o->op_type == OP_DBSTATE
1025 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1026 || o->op_targ == OP_DBSTATE)))
1027 PL_curcop = (COP*)o; /* for warning below */
1029 /* assumes no premature commitment */
1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR)
1032 || (PL_parser && PL_parser->error_count)
1033 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1038 if ((o->op_private & OPpTARGET_MY)
1039 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1041 return scalar(o); /* As if inside SASSIGN */
1044 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1046 switch (o->op_type) {
1048 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1052 if (o->op_flags & OPf_STACKED)
1056 if (o->op_private == 4)
1099 case OP_GETSOCKNAME:
1100 case OP_GETPEERNAME:
1105 case OP_GETPRIORITY:
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1130 /* Otherwise it's "Useless use of grep iterator" */
1131 useless = OP_DESC(o);
1135 kid = cLISTOPo->op_first;
1136 if (kid && kid->op_type == OP_PUSHRE
1138 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1140 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1142 useless = OP_DESC(o);
1146 kid = cUNOPo->op_first;
1147 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1148 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1151 useless = "negative pattern binding (!~)";
1155 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1156 useless = "non-destructive substitution (s///r)";
1160 useless = "non-destructive transliteration (tr///r)";
1167 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1168 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1169 useless = "a variable";
1174 if (cSVOPo->op_private & OPpCONST_STRICT)
1175 no_bareword_allowed(o);
1177 if (ckWARN(WARN_VOID)) {
1179 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1180 "a constant (%"SVf")", sv));
1181 useless = SvPV_nolen(msv);
1184 useless = "a constant (undef)";
1185 if (o->op_private & OPpCONST_ARYBASE)
1187 /* don't warn on optimised away booleans, eg
1188 * use constant Foo, 5; Foo || print; */
1189 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1191 /* the constants 0 and 1 are permitted as they are
1192 conventionally used as dummies in constructs like
1193 1 while some_condition_with_side_effects; */
1194 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1196 else if (SvPOK(sv)) {
1197 /* perl4's way of mixing documentation and code
1198 (before the invention of POD) was based on a
1199 trick to mix nroff and perl code. The trick was
1200 built upon these three nroff macros being used in
1201 void context. The pink camel has the details in
1202 the script wrapman near page 319. */
1203 const char * const maybe_macro = SvPVX_const(sv);
1204 if (strnEQ(maybe_macro, "di", 2) ||
1205 strnEQ(maybe_macro, "ds", 2) ||
1206 strnEQ(maybe_macro, "ig", 2))
1211 op_null(o); /* don't execute or even remember it */
1215 o->op_type = OP_PREINC; /* pre-increment is faster */
1216 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1220 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1221 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1225 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1230 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1231 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1236 kid = cLOGOPo->op_first;
1237 if (kid->op_type == OP_NOT
1238 && (kid->op_flags & OPf_KIDS)
1240 if (o->op_type == OP_AND) {
1242 o->op_ppaddr = PL_ppaddr[OP_OR];
1244 o->op_type = OP_AND;
1245 o->op_ppaddr = PL_ppaddr[OP_AND];
1254 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1259 if (o->op_flags & OPf_STACKED)
1266 if (!(o->op_flags & OPf_KIDS))
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1287 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1292 S_listkids(pTHX_ OP *o)
1294 if (o && o->op_flags & OPf_KIDS) {
1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1303 Perl_list(pTHX_ OP *o)
1308 /* assumes no premature commitment */
1309 if (!o || (o->op_flags & OPf_WANT)
1310 || (PL_parser && PL_parser->error_count)
1311 || o->op_type == OP_RETURN)
1316 if ((o->op_private & OPpTARGET_MY)
1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1319 return o; /* As if inside SASSIGN */
1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1324 switch (o->op_type) {
1327 list(cBINOPo->op_first);
1332 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (!(o->op_flags & OPf_KIDS))
1342 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1343 list(cBINOPo->op_first);
1344 return gen_constant_list(o);
1351 kid = cLISTOPo->op_first;
1353 kid = kid->op_sibling;
1356 OP *sib = kid->op_sibling;
1357 if (sib && kid->op_type != OP_LEAVEWHEN) {
1358 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1368 PL_curcop = &PL_compiling;
1372 kid = cLISTOPo->op_first;
1379 S_scalarseq(pTHX_ OP *o)
1383 const OPCODE type = o->op_type;
1385 if (type == OP_LINESEQ || type == OP_SCOPE ||
1386 type == OP_LEAVE || type == OP_LEAVETRY)
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1390 if (kid->op_sibling) {
1394 PL_curcop = &PL_compiling;
1396 o->op_flags &= ~OPf_PARENS;
1397 if (PL_hints & HINT_BLOCK_SCOPE)
1398 o->op_flags |= OPf_PARENS;
1401 o = newOP(OP_STUB, 0);
1406 S_modkids(pTHX_ OP *o, I32 type)
1408 if (o && o->op_flags & OPf_KIDS) {
1410 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1411 op_lvalue(kid, type);
1417 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1419 Propagate lvalue ("modifiable") context to an op and its children.
1420 I<type> represents the context type, roughly based on the type of op that
1421 would do the modifying, although C<local()> is represented by OP_NULL,
1422 because it has no op type of its own (it is signalled by a flag on
1423 the lvalue op). This function detects things that can't be modified,
1424 such as C<$x+1>, and generates errors for them. It also flags things
1425 that need to behave specially in an lvalue context, such as C<$$x>
1426 which might have to vivify a reference in C<$x>.
1432 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1436 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1439 if (!o || (PL_parser && PL_parser->error_count))
1442 if ((o->op_private & OPpTARGET_MY)
1443 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1448 switch (o->op_type) {
1454 if (!(o->op_private & OPpCONST_ARYBASE))
1457 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1458 CopARYBASE_set(&PL_compiling,
1459 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1463 SAVECOPARYBASE(&PL_compiling);
1464 CopARYBASE_set(&PL_compiling, 0);
1466 else if (type == OP_REFGEN)
1469 Perl_croak(aTHX_ "That use of $[ is unsupported");
1472 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1476 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1477 !(o->op_flags & OPf_STACKED)) {
1478 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1479 /* The default is to set op_private to the number of children,
1480 which for a UNOP such as RV2CV is always 1. And w're using
1481 the bit for a flag in RV2CV, so we need it clear. */
1482 o->op_private &= ~1;
1483 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1484 assert(cUNOPo->op_first->op_type == OP_NULL);
1485 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1488 else if (o->op_private & OPpENTERSUB_NOMOD)
1490 else { /* lvalue subroutine call */
1491 o->op_private |= OPpLVAL_INTRO;
1492 PL_modcount = RETURN_UNLIMITED_NUMBER;
1493 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1494 /* Backward compatibility mode: */
1495 o->op_private |= OPpENTERSUB_INARGS;
1498 else { /* Compile-time error message: */
1499 OP *kid = cUNOPo->op_first;
1503 if (kid->op_type != OP_PUSHMARK) {
1504 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1506 "panic: unexpected lvalue entersub "
1507 "args: type/targ %ld:%"UVuf,
1508 (long)kid->op_type, (UV)kid->op_targ);
1509 kid = kLISTOP->op_first;
1511 while (kid->op_sibling)
1512 kid = kid->op_sibling;
1513 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1515 if (kid->op_type == OP_METHOD_NAMED
1516 || kid->op_type == OP_METHOD)
1520 NewOp(1101, newop, 1, UNOP);
1521 newop->op_type = OP_RV2CV;
1522 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1523 newop->op_first = NULL;
1524 newop->op_next = (OP*)newop;
1525 kid->op_sibling = (OP*)newop;
1526 newop->op_private |= OPpLVAL_INTRO;
1527 newop->op_private &= ~1;
1531 if (kid->op_type != OP_RV2CV)
1533 "panic: unexpected lvalue entersub "
1534 "entry via type/targ %ld:%"UVuf,
1535 (long)kid->op_type, (UV)kid->op_targ);
1536 kid->op_private |= OPpLVAL_INTRO;
1537 break; /* Postpone until runtime */
1541 kid = kUNOP->op_first;
1542 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1543 kid = kUNOP->op_first;
1544 if (kid->op_type == OP_NULL)
1546 "Unexpected constant lvalue entersub "
1547 "entry via type/targ %ld:%"UVuf,
1548 (long)kid->op_type, (UV)kid->op_targ);
1549 if (kid->op_type != OP_GV) {
1550 /* Restore RV2CV to check lvalueness */
1552 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1553 okid->op_next = kid->op_next;
1554 kid->op_next = okid;
1557 okid->op_next = NULL;
1558 okid->op_type = OP_RV2CV;
1560 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1561 okid->op_private |= OPpLVAL_INTRO;
1562 okid->op_private &= ~1;
1566 cv = GvCV(kGVOP_gv);
1576 /* grep, foreach, subcalls, refgen */
1577 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1579 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1580 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1582 : (o->op_type == OP_ENTERSUB
1583 ? "non-lvalue subroutine call"
1585 type ? PL_op_desc[type] : "local"));
1599 case OP_RIGHT_SHIFT:
1608 if (!(o->op_flags & OPf_STACKED))
1615 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1616 op_lvalue(kid, type);
1621 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
1623 return o; /* Treat \(@foo) like ordinary list. */
1627 if (scalar_mod_type(o, type))
1629 ref(cUNOPo->op_first, o->op_type);
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1640 PL_modcount = RETURN_UNLIMITED_NUMBER;
1643 PL_hints |= HINT_BLOCK_SCOPE;
1644 if (type == OP_LEAVESUBLV)
1645 o->op_private |= OPpMAYBE_LVSUB;
1649 ref(cUNOPo->op_first, o->op_type);
1653 PL_hints |= HINT_BLOCK_SCOPE;
1668 PL_modcount = RETURN_UNLIMITED_NUMBER;
1669 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1670 return o; /* Treat \(@foo) like ordinary list. */
1671 if (scalar_mod_type(o, type))
1673 if (type == OP_LEAVESUBLV)
1674 o->op_private |= OPpMAYBE_LVSUB;
1678 if (!type) /* local() */
1679 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1680 PAD_COMPNAME_PV(o->op_targ));
1688 if (type != OP_SASSIGN)
1692 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1697 if (type == OP_LEAVESUBLV)
1698 o->op_private |= OPpMAYBE_LVSUB;
1700 pad_free(o->op_targ);
1701 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1702 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1703 if (o->op_flags & OPf_KIDS)
1704 op_lvalue(cBINOPo->op_first->op_sibling, type);
1709 ref(cBINOPo->op_first, o->op_type);
1710 if (type == OP_ENTERSUB &&
1711 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1712 o->op_private |= OPpLVAL_DEFER;
1713 if (type == OP_LEAVESUBLV)
1714 o->op_private |= OPpMAYBE_LVSUB;
1724 if (o->op_flags & OPf_KIDS)
1725 op_lvalue(cLISTOPo->op_last, type);
1730 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1732 else if (!(o->op_flags & OPf_KIDS))
1734 if (o->op_targ != OP_LIST) {
1735 op_lvalue(cBINOPo->op_first, type);
1741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1742 op_lvalue(kid, type);
1746 if (type != OP_LEAVESUBLV)
1748 break; /* op_lvalue()ing was handled by ck_return() */
1751 /* [20011101.069] File test operators interpret OPf_REF to mean that
1752 their argument is a filehandle; thus \stat(".") should not set
1754 if (type == OP_REFGEN &&
1755 PL_check[o->op_type] == Perl_ck_ftst)
1758 if (type != OP_LEAVESUBLV)
1759 o->op_flags |= OPf_MOD;
1761 if (type == OP_AASSIGN || type == OP_SASSIGN)
1762 o->op_flags |= OPf_SPECIAL|OPf_REF;
1763 else if (!type) { /* local() */
1766 o->op_private |= OPpLVAL_INTRO;
1767 o->op_flags &= ~OPf_SPECIAL;
1768 PL_hints |= HINT_BLOCK_SCOPE;
1773 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1774 "Useless localization of %s", OP_DESC(o));
1777 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1778 && type != OP_LEAVESUBLV)
1779 o->op_flags |= OPf_REF;
1784 S_scalar_mod_type(const OP *o, I32 type)
1786 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1790 if (o->op_type == OP_RV2GV)
1814 case OP_RIGHT_SHIFT:
1835 S_is_handle_constructor(const OP *o, I32 numargs)
1837 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1839 switch (o->op_type) {
1847 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1860 S_refkids(pTHX_ OP *o, I32 type)
1862 if (o && o->op_flags & OPf_KIDS) {
1864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1871 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1876 PERL_ARGS_ASSERT_DOREF;
1878 if (!o || (PL_parser && PL_parser->error_count))
1881 switch (o->op_type) {
1883 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1884 !(o->op_flags & OPf_STACKED)) {
1885 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1886 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1887 assert(cUNOPo->op_first->op_type == OP_NULL);
1888 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1889 o->op_flags |= OPf_SPECIAL;
1890 o->op_private &= ~1;
1895 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1896 doref(kid, type, set_op_ref);
1899 if (type == OP_DEFINED)
1900 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1901 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1904 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1905 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1906 : type == OP_RV2HV ? OPpDEREF_HV
1908 o->op_flags |= OPf_MOD;
1915 o->op_flags |= OPf_REF;
1918 if (type == OP_DEFINED)
1919 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1920 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1926 o->op_flags |= OPf_REF;
1931 if (!(o->op_flags & OPf_KIDS))
1933 doref(cBINOPo->op_first, type, set_op_ref);
1937 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1938 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1939 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1940 : type == OP_RV2HV ? OPpDEREF_HV
1942 o->op_flags |= OPf_MOD;
1952 if (!(o->op_flags & OPf_KIDS))
1954 doref(cLISTOPo->op_last, type, set_op_ref);
1964 S_dup_attrlist(pTHX_ OP *o)
1969 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1971 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1972 * where the first kid is OP_PUSHMARK and the remaining ones
1973 * are OP_CONST. We need to push the OP_CONST values.
1975 if (o->op_type == OP_CONST)
1976 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1978 else if (o->op_type == OP_NULL)
1982 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1984 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1985 if (o->op_type == OP_CONST)
1986 rop = op_append_elem(OP_LIST, rop,
1987 newSVOP(OP_CONST, o->op_flags,
1988 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1995 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2000 PERL_ARGS_ASSERT_APPLY_ATTRS;
2002 /* fake up C<use attributes $pkg,$rv,@attrs> */
2003 ENTER; /* need to protect against side-effects of 'use' */
2004 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2006 #define ATTRSMODULE "attributes"
2007 #define ATTRSMODULE_PM "attributes.pm"
2010 /* Don't force the C<use> if we don't need it. */
2011 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2012 if (svp && *svp != &PL_sv_undef)
2013 NOOP; /* already in %INC */
2015 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2016 newSVpvs(ATTRSMODULE), NULL);
2019 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2020 newSVpvs(ATTRSMODULE),
2022 op_prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0, stashsv),
2024 op_prepend_elem(OP_LIST,
2025 newSVOP(OP_CONST, 0,
2027 dup_attrlist(attrs))));
2033 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2036 OP *pack, *imop, *arg;
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2044 assert(target->op_type == OP_PADSV ||
2045 target->op_type == OP_PADHV ||
2046 target->op_type == OP_PADAV);
2048 /* Ensure that attributes.pm is loaded. */
2049 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2051 /* Need package name for method call. */
2052 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2054 /* Build up the real arg-list. */
2055 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2057 arg = newOP(OP_PADSV, 0);
2058 arg->op_targ = target->op_targ;
2059 arg = op_prepend_elem(OP_LIST,
2060 newSVOP(OP_CONST, 0, stashsv),
2061 op_prepend_elem(OP_LIST,
2062 newUNOP(OP_REFGEN, 0,
2063 op_lvalue(arg, OP_REFGEN)),
2064 dup_attrlist(attrs)));
2066 /* Fake up a method call to import */
2067 meth = newSVpvs_share("import");
2068 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2069 op_append_elem(OP_LIST,
2070 op_prepend_elem(OP_LIST, pack, list(arg)),
2071 newSVOP(OP_METHOD_NAMED, 0, meth)));
2072 imop->op_private |= OPpENTERSUB_NOMOD;
2074 /* Combine the ops. */
2075 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2079 =notfor apidoc apply_attrs_string
2081 Attempts to apply a list of attributes specified by the C<attrstr> and
2082 C<len> arguments to the subroutine identified by the C<cv> argument which
2083 is expected to be associated with the package identified by the C<stashpv>
2084 argument (see L<attributes>). It gets this wrong, though, in that it
2085 does not correctly identify the boundaries of the individual attribute
2086 specifications within C<attrstr>. This is not really intended for the
2087 public API, but has to be listed here for systems such as AIX which
2088 need an explicit export list for symbols. (It's called from XS code
2089 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2090 to respect attribute syntax properly would be welcome.
2096 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2097 const char *attrstr, STRLEN len)
2101 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2104 len = strlen(attrstr);
2108 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2110 const char * const sstr = attrstr;
2111 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2112 attrs = op_append_elem(OP_LIST, attrs,
2113 newSVOP(OP_CONST, 0,
2114 newSVpvn(sstr, attrstr-sstr)));
2118 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2119 newSVpvs(ATTRSMODULE),
2120 NULL, op_prepend_elem(OP_LIST,
2121 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2122 op_prepend_elem(OP_LIST,
2123 newSVOP(OP_CONST, 0,
2124 newRV(MUTABLE_SV(cv))),
2129 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2134 PERL_ARGS_ASSERT_MY_KID;
2136 if (!o || (PL_parser && PL_parser->error_count))
2140 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2141 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2145 if (type == OP_LIST) {
2147 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2148 my_kid(kid, attrs, imopsp);
2149 } else if (type == OP_UNDEF
2155 } else if (type == OP_RV2SV || /* "our" declaration */
2157 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2159 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2161 PL_parser->in_my == KEY_our
2163 : PL_parser->in_my == KEY_state ? "state" : "my"));
2165 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2166 PL_parser->in_my = FALSE;
2167 PL_parser->in_my_stash = NULL;
2168 apply_attrs(GvSTASH(gv),
2169 (type == OP_RV2SV ? GvSV(gv) :
2170 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2171 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2174 o->op_private |= OPpOUR_INTRO;
2177 else if (type != OP_PADSV &&
2180 type != OP_PUSHMARK)
2182 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2184 PL_parser->in_my == KEY_our
2186 : PL_parser->in_my == KEY_state ? "state" : "my"));
2189 else if (attrs && type != OP_PUSHMARK) {
2192 PL_parser->in_my = FALSE;
2193 PL_parser->in_my_stash = NULL;
2195 /* check for C<my Dog $spot> when deciding package */
2196 stash = PAD_COMPNAME_TYPE(o->op_targ);
2198 stash = PL_curstash;
2199 apply_attrs_my(stash, o, attrs, imopsp);
2201 o->op_flags |= OPf_MOD;
2202 o->op_private |= OPpLVAL_INTRO;
2203 if (PL_parser->in_my == KEY_state)
2204 o->op_private |= OPpPAD_STATE;
2209 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2213 int maybe_scalar = 0;
2215 PERL_ARGS_ASSERT_MY_ATTRS;
2217 /* [perl #17376]: this appears to be premature, and results in code such as
2218 C< our(%x); > executing in list mode rather than void mode */
2220 if (o->op_flags & OPf_PARENS)
2230 o = my_kid(o, attrs, &rops);
2232 if (maybe_scalar && o->op_type == OP_PADSV) {
2233 o = scalar(op_append_list(OP_LIST, rops, o));
2234 o->op_private |= OPpLVAL_INTRO;
2237 o = op_append_list(OP_LIST, o, rops);
2239 PL_parser->in_my = FALSE;
2240 PL_parser->in_my_stash = NULL;
2245 Perl_sawparens(pTHX_ OP *o)
2247 PERL_UNUSED_CONTEXT;
2249 o->op_flags |= OPf_PARENS;
2254 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2258 const OPCODE ltype = left->op_type;
2259 const OPCODE rtype = right->op_type;
2261 PERL_ARGS_ASSERT_BIND_MATCH;
2263 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2264 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2266 const char * const desc
2268 rtype == OP_SUBST || rtype == OP_TRANS
2269 || rtype == OP_TRANSR
2271 ? (int)rtype : OP_MATCH];
2272 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2273 ? "@array" : "%hash");
2274 Perl_warner(aTHX_ packWARN(WARN_MISC),
2275 "Applying %s to %s will act on scalar(%s)",
2276 desc, sample, sample);
2279 if (rtype == OP_CONST &&
2280 cSVOPx(right)->op_private & OPpCONST_BARE &&
2281 cSVOPx(right)->op_private & OPpCONST_STRICT)
2283 no_bareword_allowed(right);
2286 /* !~ doesn't make sense with /r, so error on it for now */
2287 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2289 yyerror("Using !~ with s///r doesn't make sense");
2290 if (rtype == OP_TRANSR && type == OP_NOT)
2291 yyerror("Using !~ with tr///r doesn't make sense");
2293 ismatchop = (rtype == OP_MATCH ||
2294 rtype == OP_SUBST ||
2295 rtype == OP_TRANS || rtype == OP_TRANSR)
2296 && !(right->op_flags & OPf_SPECIAL);
2297 if (ismatchop && right->op_private & OPpTARGET_MY) {
2299 right->op_private &= ~OPpTARGET_MY;
2301 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2304 right->op_flags |= OPf_STACKED;
2305 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2306 ! (rtype == OP_TRANS &&
2307 right->op_private & OPpTRANS_IDENTICAL) &&
2308 ! (rtype == OP_SUBST &&
2309 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2310 newleft = op_lvalue(left, rtype);
2313 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2314 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2316 o = op_prepend_elem(rtype, scalar(newleft), right);
2318 return newUNOP(OP_NOT, 0, scalar(o));
2322 return bind_match(type, left,
2323 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2327 Perl_invert(pTHX_ OP *o)
2331 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2335 =for apidoc Amx|OP *|op_scope|OP *o
2337 Wraps up an op tree with some additional ops so that at runtime a dynamic
2338 scope will be created. The original ops run in the new dynamic scope,
2339 and then, provided that they exit normally, the scope will be unwound.
2340 The additional ops used to create and unwind the dynamic scope will
2341 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2342 instead if the ops are simple enough to not need the full dynamic scope
2349 Perl_op_scope(pTHX_ OP *o)
2353 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2354 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2355 o->op_type = OP_LEAVE;
2356 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2358 else if (o->op_type == OP_LINESEQ) {
2360 o->op_type = OP_SCOPE;
2361 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2362 kid = ((LISTOP*)o)->op_first;
2363 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2366 /* The following deals with things like 'do {1 for 1}' */
2367 kid = kid->op_sibling;
2369 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2374 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2380 Perl_block_start(pTHX_ int full)
2383 const int retval = PL_savestack_ix;
2385 pad_block_start(full);
2387 PL_hints &= ~HINT_BLOCK_SCOPE;
2388 SAVECOMPILEWARNINGS();
2389 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2391 CALL_BLOCK_HOOKS(bhk_start, full);
2397 Perl_block_end(pTHX_ I32 floor, OP *seq)
2400 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2401 OP* retval = scalarseq(seq);
2403 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2406 CopHINTS_set(&PL_compiling, PL_hints);
2408 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2411 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2417 =head1 Compile-time scope hooks
2419 =for apidoc Ao||blockhook_register
2421 Register a set of hooks to be called when the Perl lexical scope changes
2422 at compile time. See L<perlguts/"Compile-time scope hooks">.
2428 Perl_blockhook_register(pTHX_ BHK *hk)
2430 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2432 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2439 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2440 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2441 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2444 OP * const o = newOP(OP_PADSV, 0);
2445 o->op_targ = offset;
2451 Perl_newPROG(pTHX_ OP *o)
2455 PERL_ARGS_ASSERT_NEWPROG;
2460 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2461 ((PL_in_eval & EVAL_KEEPERR)
2462 ? OPf_SPECIAL : 0), o);
2463 /* don't use LINKLIST, since PL_eval_root might indirect through
2464 * a rather expensive function call and LINKLIST evaluates its
2465 * argument more than once */
2466 PL_eval_start = op_linklist(PL_eval_root);
2467 PL_eval_root->op_private |= OPpREFCOUNTED;
2468 OpREFCNT_set(PL_eval_root, 1);
2469 PL_eval_root->op_next = 0;
2470 CALL_PEEP(PL_eval_start);
2473 if (o->op_type == OP_STUB) {
2474 PL_comppad_name = 0;
2476 S_op_destroy(aTHX_ o);
2479 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2480 PL_curcop = &PL_compiling;
2481 PL_main_start = LINKLIST(PL_main_root);
2482 PL_main_root->op_private |= OPpREFCOUNTED;
2483 OpREFCNT_set(PL_main_root, 1);
2484 PL_main_root->op_next = 0;
2485 CALL_PEEP(PL_main_start);
2488 /* Register with debugger */
2490 CV * const cv = get_cvs("DB::postponed", 0);
2494 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2496 call_sv(MUTABLE_SV(cv), G_DISCARD);
2503 Perl_localize(pTHX_ OP *o, I32 lex)
2507 PERL_ARGS_ASSERT_LOCALIZE;
2509 if (o->op_flags & OPf_PARENS)
2510 /* [perl #17376]: this appears to be premature, and results in code such as
2511 C< our(%x); > executing in list mode rather than void mode */
2518 if ( PL_parser->bufptr > PL_parser->oldbufptr
2519 && PL_parser->bufptr[-1] == ','
2520 && ckWARN(WARN_PARENTHESIS))
2522 char *s = PL_parser->bufptr;
2525 /* some heuristics to detect a potential error */
2526 while (*s && (strchr(", \t\n", *s)))
2530 if (*s && strchr("@$%*", *s) && *++s
2531 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2534 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2536 while (*s && (strchr(", \t\n", *s)))
2542 if (sigil && (*s == ';' || *s == '=')) {
2543 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2544 "Parentheses missing around \"%s\" list",
2546 ? (PL_parser->in_my == KEY_our
2548 : PL_parser->in_my == KEY_state
2558 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2559 PL_parser->in_my = FALSE;
2560 PL_parser->in_my_stash = NULL;
2565 Perl_jmaybe(pTHX_ OP *o)
2567 PERL_ARGS_ASSERT_JMAYBE;
2569 if (o->op_type == OP_LIST) {
2571 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2572 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2578 S_fold_constants(pTHX_ register OP *o)
2581 register OP * VOL curop;
2583 VOL I32 type = o->op_type;
2588 SV * const oldwarnhook = PL_warnhook;
2589 SV * const olddiehook = PL_diehook;
2593 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2595 if (PL_opargs[type] & OA_RETSCALAR)
2597 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2598 o->op_targ = pad_alloc(type, SVs_PADTMP);
2600 /* integerize op, unless it happens to be C<-foo>.
2601 * XXX should pp_i_negate() do magic string negation instead? */
2602 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2603 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2604 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2606 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2609 if (!(PL_opargs[type] & OA_FOLDCONST))
2614 /* XXX might want a ck_negate() for this */
2615 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2627 /* XXX what about the numeric ops? */
2628 if (PL_hints & HINT_LOCALE)
2633 if (PL_parser && PL_parser->error_count)
2634 goto nope; /* Don't try to run w/ errors */
2636 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2637 const OPCODE type = curop->op_type;
2638 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2640 type != OP_SCALAR &&
2642 type != OP_PUSHMARK)
2648 curop = LINKLIST(o);
2649 old_next = o->op_next;
2653 oldscope = PL_scopestack_ix;
2654 create_eval_scope(G_FAKINGEVAL);
2656 /* Verify that we don't need to save it: */
2657 assert(PL_curcop == &PL_compiling);
2658 StructCopy(&PL_compiling, ¬_compiling, COP);
2659 PL_curcop = ¬_compiling;
2660 /* The above ensures that we run with all the correct hints of the
2661 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2662 assert(IN_PERL_RUNTIME);
2663 PL_warnhook = PERL_WARNHOOK_FATAL;
2670 sv = *(PL_stack_sp--);
2671 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2672 pad_swipe(o->op_targ, FALSE);
2673 else if (SvTEMP(sv)) { /* grab mortal temp? */
2674 SvREFCNT_inc_simple_void(sv);
2679 /* Something tried to die. Abandon constant folding. */
2680 /* Pretend the error never happened. */
2682 o->op_next = old_next;
2686 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2687 PL_warnhook = oldwarnhook;
2688 PL_diehook = olddiehook;
2689 /* XXX note that this croak may fail as we've already blown away
2690 * the stack - eg any nested evals */
2691 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2694 PL_warnhook = oldwarnhook;
2695 PL_diehook = olddiehook;
2696 PL_curcop = &PL_compiling;
2698 if (PL_scopestack_ix > oldscope)
2699 delete_eval_scope();
2708 if (type == OP_RV2GV)
2709 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2711 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2712 op_getmad(o,newop,'f');
2720 S_gen_constant_list(pTHX_ register OP *o)
2724 const I32 oldtmps_floor = PL_tmps_floor;
2727 if (PL_parser && PL_parser->error_count)
2728 return o; /* Don't attempt to run with errors */
2730 PL_op = curop = LINKLIST(o);
2736 assert (!(curop->op_flags & OPf_SPECIAL));
2737 assert(curop->op_type == OP_RANGE);
2739 PL_tmps_floor = oldtmps_floor;
2741 o->op_type = OP_RV2AV;
2742 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2743 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2744 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2745 o->op_opt = 0; /* needs to be revisited in rpeep() */
2746 curop = ((UNOP*)o)->op_first;
2747 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2749 op_getmad(curop,o,'O');
2758 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2761 if (!o || o->op_type != OP_LIST)
2762 o = newLISTOP(OP_LIST, 0, o, NULL);
2764 o->op_flags &= ~OPf_WANT;
2766 if (!(PL_opargs[type] & OA_MARK))
2767 op_null(cLISTOPo->op_first);
2769 o->op_type = (OPCODE)type;
2770 o->op_ppaddr = PL_ppaddr[type];
2771 o->op_flags |= flags;
2773 o = CHECKOP(type, o);
2774 if (o->op_type != (unsigned)type)
2777 return fold_constants(o);
2781 =head1 Optree Manipulation Functions
2784 /* List constructors */
2787 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2789 Append an item to the list of ops contained directly within a list-type
2790 op, returning the lengthened list. I<first> is the list-type op,
2791 and I<last> is the op to append to the list. I<optype> specifies the
2792 intended opcode for the list. If I<first> is not already a list of the
2793 right type, it will be upgraded into one. If either I<first> or I<last>
2794 is null, the other is returned unchanged.
2800 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2808 if (first->op_type != (unsigned)type
2809 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2811 return newLISTOP(type, 0, first, last);
2814 if (first->op_flags & OPf_KIDS)
2815 ((LISTOP*)first)->op_last->op_sibling = last;
2817 first->op_flags |= OPf_KIDS;
2818 ((LISTOP*)first)->op_first = last;
2820 ((LISTOP*)first)->op_last = last;
2825 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2827 Concatenate the lists of ops contained directly within two list-type ops,
2828 returning the combined list. I<first> and I<last> are the list-type ops
2829 to concatenate. I<optype> specifies the intended opcode for the list.
2830 If either I<first> or I<last> is not already a list of the right type,
2831 it will be upgraded into one. If either I<first> or I<last> is null,
2832 the other is returned unchanged.
2838 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2846 if (first->op_type != (unsigned)type)
2847 return op_prepend_elem(type, first, last);
2849 if (last->op_type != (unsigned)type)
2850 return op_append_elem(type, first, last);
2852 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2853 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2854 first->op_flags |= (last->op_flags & OPf_KIDS);
2857 if (((LISTOP*)last)->op_first && first->op_madprop) {
2858 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2860 while (mp->mad_next)
2862 mp->mad_next = first->op_madprop;
2865 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2868 first->op_madprop = last->op_madprop;
2869 last->op_madprop = 0;
2872 S_op_destroy(aTHX_ last);
2878 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2880 Prepend an item to the list of ops contained directly within a list-type
2881 op, returning the lengthened list. I<first> is the op to prepend to the
2882 list, and I<last> is the list-type op. I<optype> specifies the intended
2883 opcode for the list. If I<last> is not already a list of the right type,
2884 it will be upgraded into one. If either I<first> or I<last> is null,
2885 the other is returned unchanged.
2891 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2899 if (last->op_type == (unsigned)type) {
2900 if (type == OP_LIST) { /* already a PUSHMARK there */
2901 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2902 ((LISTOP*)last)->op_first->op_sibling = first;
2903 if (!(first->op_flags & OPf_PARENS))
2904 last->op_flags &= ~OPf_PARENS;
2907 if (!(last->op_flags & OPf_KIDS)) {
2908 ((LISTOP*)last)->op_last = first;
2909 last->op_flags |= OPf_KIDS;
2911 first->op_sibling = ((LISTOP*)last)->op_first;
2912 ((LISTOP*)last)->op_first = first;
2914 last->op_flags |= OPf_KIDS;
2918 return newLISTOP(type, 0, first, last);
2926 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2929 Newxz(tk, 1, TOKEN);
2930 tk->tk_type = (OPCODE)optype;
2931 tk->tk_type = 12345;
2933 tk->tk_mad = madprop;
2938 Perl_token_free(pTHX_ TOKEN* tk)
2940 PERL_ARGS_ASSERT_TOKEN_FREE;
2942 if (tk->tk_type != 12345)
2944 mad_free(tk->tk_mad);
2949 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2954 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2956 if (tk->tk_type != 12345) {
2957 Perl_warner(aTHX_ packWARN(WARN_MISC),
2958 "Invalid TOKEN object ignored");
2965 /* faked up qw list? */
2967 tm->mad_type == MAD_SV &&
2968 SvPVX((SV *)tm->mad_val)[0] == 'q')
2975 /* pretend constant fold didn't happen? */
2976 if (mp->mad_key == 'f' &&
2977 (o->op_type == OP_CONST ||
2978 o->op_type == OP_GV) )
2980 token_getmad(tk,(OP*)mp->mad_val,slot);
2994 if (mp->mad_key == 'X')
2995 mp->mad_key = slot; /* just change the first one */
3005 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3014 /* pretend constant fold didn't happen? */
3015 if (mp->mad_key == 'f' &&
3016 (o->op_type == OP_CONST ||
3017 o->op_type == OP_GV) )
3019 op_getmad(from,(OP*)mp->mad_val,slot);
3026 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3029 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3035 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3044 /* pretend constant fold didn't happen? */
3045 if (mp->mad_key == 'f' &&
3046 (o->op_type == OP_CONST ||
3047 o->op_type == OP_GV) )
3049 op_getmad(from,(OP*)mp->mad_val,slot);
3056 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3059 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3063 PerlIO_printf(PerlIO_stderr(),
3064 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3070 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3088 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3092 addmad(tm, &(o->op_madprop), slot);
3096 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3117 Perl_newMADsv(pTHX_ char key, SV* sv)
3119 PERL_ARGS_ASSERT_NEWMADSV;
3121 return newMADPROP(key, MAD_SV, sv, 0);
3125 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3128 Newxz(mp, 1, MADPROP);
3131 mp->mad_vlen = vlen;
3132 mp->mad_type = type;
3134 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3139 Perl_mad_free(pTHX_ MADPROP* mp)
3141 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3145 mad_free(mp->mad_next);
3146 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3147 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3148 switch (mp->mad_type) {
3152 Safefree((char*)mp->mad_val);
3155 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3156 op_free((OP*)mp->mad_val);
3159 sv_free(MUTABLE_SV(mp->mad_val));
3162 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3171 =head1 Optree construction
3173 =for apidoc Am|OP *|newNULLLIST
3175 Constructs, checks, and returns a new C<stub> op, which represents an
3176 empty list expression.
3182 Perl_newNULLLIST(pTHX)
3184 return newOP(OP_STUB, 0);
3188 S_force_list(pTHX_ OP *o)
3190 if (!o || o->op_type != OP_LIST)
3191 o = newLISTOP(OP_LIST, 0, o, NULL);
3197 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3199 Constructs, checks, and returns an op of any list type. I<type> is
3200 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3201 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3202 supply up to two ops to be direct children of the list op; they are
3203 consumed by this function and become part of the constructed op tree.
3209 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3214 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3216 NewOp(1101, listop, 1, LISTOP);
3218 listop->op_type = (OPCODE)type;
3219 listop->op_ppaddr = PL_ppaddr[type];
3222 listop->op_flags = (U8)flags;
3226 else if (!first && last)
3229 first->op_sibling = last;
3230 listop->op_first = first;
3231 listop->op_last = last;
3232 if (type == OP_LIST) {
3233 OP* const pushop = newOP(OP_PUSHMARK, 0);
3234 pushop->op_sibling = first;
3235 listop->op_first = pushop;
3236 listop->op_flags |= OPf_KIDS;
3238 listop->op_last = pushop;
3241 return CHECKOP(type, listop);
3245 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3247 Constructs, checks, and returns an op of any base type (any type that
3248 has no extra fields). I<type> is the opcode. I<flags> gives the
3249 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3256 Perl_newOP(pTHX_ I32 type, I32 flags)
3261 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3262 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3263 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3264 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3266 NewOp(1101, o, 1, OP);
3267 o->op_type = (OPCODE)type;
3268 o->op_ppaddr = PL_ppaddr[type];
3269 o->op_flags = (U8)flags;
3271 o->op_latefreed = 0;
3275 o->op_private = (U8)(0 | (flags >> 8));
3276 if (PL_opargs[type] & OA_RETSCALAR)
3278 if (PL_opargs[type] & OA_TARGET)
3279 o->op_targ = pad_alloc(type, SVs_PADTMP);
3280 return CHECKOP(type, o);
3284 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3286 Constructs, checks, and returns an op of any unary type. I<type> is
3287 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3288 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3289 bits, the eight bits of C<op_private>, except that the bit with value 1
3290 is automatically set. I<first> supplies an optional op to be the direct
3291 child of the unary op; it is consumed by this function and become part
3292 of the constructed op tree.
3298 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3303 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3304 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3305 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3306 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3307 || type == OP_SASSIGN
3308 || type == OP_ENTERTRY
3309 || type == OP_NULL );
3312 first = newOP(OP_STUB, 0);
3313 if (PL_opargs[type] & OA_MARK)
3314 first = force_list(first);
3316 NewOp(1101, unop, 1, UNOP);
3317 unop->op_type = (OPCODE)type;
3318 unop->op_ppaddr = PL_ppaddr[type];
3319 unop->op_first = first;
3320 unop->op_flags = (U8)(flags | OPf_KIDS);
3321 unop->op_private = (U8)(1 | (flags >> 8));
3322 unop = (UNOP*) CHECKOP(type, unop);
3326 return fold_constants((OP *) unop);
3330 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3332 Constructs, checks, and returns an op of any binary type. I<type>
3333 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3334 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3335 the eight bits of C<op_private>, except that the bit with value 1 or
3336 2 is automatically set as required. I<first> and I<last> supply up to
3337 two ops to be the direct children of the binary op; they are consumed
3338 by this function and become part of the constructed op tree.
3344 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3349 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3350 || type == OP_SASSIGN || type == OP_NULL );
3352 NewOp(1101, binop, 1, BINOP);
3355 first = newOP(OP_NULL, 0);
3357 binop->op_type = (OPCODE)type;
3358 binop->op_ppaddr = PL_ppaddr[type];
3359 binop->op_first = first;
3360 binop->op_flags = (U8)(flags | OPf_KIDS);
3363 binop->op_private = (U8)(1 | (flags >> 8));
3366 binop->op_private = (U8)(2 | (flags >> 8));
3367 first->op_sibling = last;
3370 binop = (BINOP*)CHECKOP(type, binop);
3371 if (binop->op_next || binop->op_type != (OPCODE)type)
3374 binop->op_last = binop->op_first->op_sibling;
3376 return fold_constants((OP *)binop);
3379 static int uvcompare(const void *a, const void *b)
3380 __attribute__nonnull__(1)
3381 __attribute__nonnull__(2)
3382 __attribute__pure__;
3383 static int uvcompare(const void *a, const void *b)
3385 if (*((const UV *)a) < (*(const UV *)b))
3387 if (*((const UV *)a) > (*(const UV *)b))
3389 if (*((const UV *)a+1) < (*(const UV *)b+1))
3391 if (*((const UV *)a+1) > (*(const UV *)b+1))
3397 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3400 SV * const tstr = ((SVOP*)expr)->op_sv;
3403 (repl->op_type == OP_NULL)
3404 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3406 ((SVOP*)repl)->op_sv;
3409 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3410 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3414 register short *tbl;
3416 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3417 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3418 I32 del = o->op_private & OPpTRANS_DELETE;
3421 PERL_ARGS_ASSERT_PMTRANS;
3423 PL_hints |= HINT_BLOCK_SCOPE;
3426 o->op_private |= OPpTRANS_FROM_UTF;
3429 o->op_private |= OPpTRANS_TO_UTF;
3431 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3432 SV* const listsv = newSVpvs("# comment\n");
3434 const U8* tend = t + tlen;
3435 const U8* rend = r + rlen;
3449 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3450 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3453 const U32 flags = UTF8_ALLOW_DEFAULT;
3457 t = tsave = bytes_to_utf8(t, &len);
3460 if (!to_utf && rlen) {
3462 r = rsave = bytes_to_utf8(r, &len);
3466 /* There are several snags with this code on EBCDIC:
3467 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3468 2. scan_const() in toke.c has encoded chars in native encoding which makes
3469 ranges at least in EBCDIC 0..255 range the bottom odd.
3473 U8 tmpbuf[UTF8_MAXBYTES+1];
3476 Newx(cp, 2*tlen, UV);
3478 transv = newSVpvs("");
3480 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3482 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3484 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3488 cp[2*i+1] = cp[2*i];
3492 qsort(cp, i, 2*sizeof(UV), uvcompare);
3493 for (j = 0; j < i; j++) {
3495 diff = val - nextmin;
3497 t = uvuni_to_utf8(tmpbuf,nextmin);
3498 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3500 U8 range_mark = UTF_TO_NATIVE(0xff);
3501 t = uvuni_to_utf8(tmpbuf, val - 1);
3502 sv_catpvn(transv, (char *)&range_mark, 1);
3503 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3510 t = uvuni_to_utf8(tmpbuf,nextmin);
3511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3513 U8 range_mark = UTF_TO_NATIVE(0xff);
3514 sv_catpvn(transv, (char *)&range_mark, 1);
3516 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3517 UNICODE_ALLOW_SUPER);
3518 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3519 t = (const U8*)SvPVX_const(transv);
3520 tlen = SvCUR(transv);
3524 else if (!rlen && !del) {
3525 r = t; rlen = tlen; rend = tend;
3528 if ((!rlen && !del) || t == r ||
3529 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3531 o->op_private |= OPpTRANS_IDENTICAL;
3535 while (t < tend || tfirst <= tlast) {
3536 /* see if we need more "t" chars */
3537 if (tfirst > tlast) {
3538 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3540 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3542 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3549 /* now see if we need more "r" chars */
3550 if (rfirst > rlast) {
3552 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3554 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3556 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3565 rfirst = rlast = 0xffffffff;
3569 /* now see which range will peter our first, if either. */
3570 tdiff = tlast - tfirst;
3571 rdiff = rlast - rfirst;
3578 if (rfirst == 0xffffffff) {
3579 diff = tdiff; /* oops, pretend rdiff is infinite */
3581 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3582 (long)tfirst, (long)tlast);
3584 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3588 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3589 (long)tfirst, (long)(tfirst + diff),
3592 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3593 (long)tfirst, (long)rfirst);
3595 if (rfirst + diff > max)
3596 max = rfirst + diff;
3598 grows = (tfirst < rfirst &&
3599 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3611 else if (max > 0xff)
3616 PerlMemShared_free(cPVOPo->op_pv);
3617 cPVOPo->op_pv = NULL;
3619 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3621 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3622 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3623 PAD_SETSV(cPADOPo->op_padix, swash);
3625 SvREADONLY_on(swash);
3627 cSVOPo->op_sv = swash;
3629 SvREFCNT_dec(listsv);
3630 SvREFCNT_dec(transv);
3632 if (!del && havefinal && rlen)
3633 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3634 newSVuv((UV)final), 0);
3637 o->op_private |= OPpTRANS_GROWS;
3643 op_getmad(expr,o,'e');
3644 op_getmad(repl,o,'r');
3652 tbl = (short*)cPVOPo->op_pv;
3654 Zero(tbl, 256, short);
3655 for (i = 0; i < (I32)tlen; i++)
3657 for (i = 0, j = 0; i < 256; i++) {
3659 if (j >= (I32)rlen) {
3668 if (i < 128 && r[j] >= 128)
3678 o->op_private |= OPpTRANS_IDENTICAL;
3680 else if (j >= (I32)rlen)
3685 PerlMemShared_realloc(tbl,
3686 (0x101+rlen-j) * sizeof(short));
3687 cPVOPo->op_pv = (char*)tbl;
3689 tbl[0x100] = (short)(rlen - j);
3690 for (i=0; i < (I32)rlen - j; i++)
3691 tbl[0x101+i] = r[j+i];
3695 if (!rlen && !del) {
3698 o->op_private |= OPpTRANS_IDENTICAL;
3700 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3701 o->op_private |= OPpTRANS_IDENTICAL;
3703 for (i = 0; i < 256; i++)
3705 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3706 if (j >= (I32)rlen) {
3708 if (tbl[t[i]] == -1)
3714 if (tbl[t[i]] == -1) {
3715 if (t[i] < 128 && r[j] >= 128)
3722 if(del && rlen == tlen) {
3723 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3724 } else if(rlen > tlen) {
3725 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3729 o->op_private |= OPpTRANS_GROWS;
3731 op_getmad(expr,o,'e');
3732 op_getmad(repl,o,'r');
3742 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3744 Constructs, checks, and returns an op of any pattern matching type.
3745 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3746 and, shifted up eight bits, the eight bits of C<op_private>.
3752 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3759 NewOp(1101, pmop, 1, PMOP);
3760 pmop->op_type = (OPCODE)type;
3761 pmop->op_ppaddr = PL_ppaddr[type];
3762 pmop->op_flags = (U8)flags;
3763 pmop->op_private = (U8)(0 | (flags >> 8));
3765 if (PL_hints & HINT_RE_TAINT)
3766 pmop->op_pmflags |= PMf_RETAINT;
3767 if (PL_hints & HINT_LOCALE) {
3768 pmop->op_pmflags |= PMf_LOCALE;
3770 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3771 pmop->op_pmflags |= RXf_PMf_UNICODE;
3773 if (PL_hints & HINT_RE_FLAGS) {
3774 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3775 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3777 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3778 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3779 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3781 if (reflags && SvOK(reflags)) {
3782 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3783 pmop->op_pmflags |= SvIV(reflags);
3789 assert(SvPOK(PL_regex_pad[0]));
3790 if (SvCUR(PL_regex_pad[0])) {
3791 /* Pop off the "packed" IV from the end. */
3792 SV *const repointer_list = PL_regex_pad[0];
3793 const char *p = SvEND(repointer_list) - sizeof(IV);
3794 const IV offset = *((IV*)p);
3796 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3798 SvEND_set(repointer_list, p);
3800 pmop->op_pmoffset = offset;
3801 /* This slot should be free, so assert this: */
3802 assert(PL_regex_pad[offset] == &PL_sv_undef);
3804 SV * const repointer = &PL_sv_undef;
3805 av_push(PL_regex_padav, repointer);
3806 pmop->op_pmoffset = av_len(PL_regex_padav);
3807 PL_regex_pad = AvARRAY(PL_regex_padav);
3811 return CHECKOP(type, pmop);
3814 /* Given some sort of match op o, and an expression expr containing a
3815 * pattern, either compile expr into a regex and attach it to o (if it's
3816 * constant), or convert expr into a runtime regcomp op sequence (if it's
3819 * isreg indicates that the pattern is part of a regex construct, eg
3820 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3821 * split "pattern", which aren't. In the former case, expr will be a list
3822 * if the pattern contains more than one term (eg /a$b/) or if it contains
3823 * a replacement, ie s/// or tr///.
3827 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3832 I32 repl_has_vars = 0;
3836 PERL_ARGS_ASSERT_PMRUNTIME;
3839 o->op_type == OP_SUBST
3840 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3842 /* last element in list is the replacement; pop it */
3844 repl = cLISTOPx(expr)->op_last;
3845 kid = cLISTOPx(expr)->op_first;
3846 while (kid->op_sibling != repl)
3847 kid = kid->op_sibling;
3848 kid->op_sibling = NULL;
3849 cLISTOPx(expr)->op_last = kid;
3852 if (isreg && expr->op_type == OP_LIST &&
3853 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3855 /* convert single element list to element */
3856 OP* const oe = expr;
3857 expr = cLISTOPx(oe)->op_first->op_sibling;
3858 cLISTOPx(oe)->op_first->op_sibling = NULL;
3859 cLISTOPx(oe)->op_last = NULL;
3863 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3864 return pmtrans(o, expr, repl);
3867 reglist = isreg && expr->op_type == OP_LIST;
3871 PL_hints |= HINT_BLOCK_SCOPE;
3874 if (expr->op_type == OP_CONST) {
3875 SV *pat = ((SVOP*)expr)->op_sv;
3876 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3878 if (o->op_flags & OPf_SPECIAL)
3879 pm_flags |= RXf_SPLIT;
3882 assert (SvUTF8(pat));
3883 } else if (SvUTF8(pat)) {
3884 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3885 trapped in use 'bytes'? */
3886 /* Make a copy of the octet sequence, but without the flag on, as
3887 the compiler now honours the SvUTF8 flag on pat. */
3889 const char *const p = SvPV(pat, len);
3890 pat = newSVpvn_flags(p, len, SVs_TEMP);
3893 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3896 op_getmad(expr,(OP*)pm,'e');
3902 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3903 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3905 : OP_REGCMAYBE),0,expr);
3907 NewOp(1101, rcop, 1, LOGOP);
3908 rcop->op_type = OP_REGCOMP;
3909 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3910 rcop->op_first = scalar(expr);
3911 rcop->op_flags |= OPf_KIDS
3912 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3913 | (reglist ? OPf_STACKED : 0);
3914 rcop->op_private = 1;
3917 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3919 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3922 /* establish postfix order */
3923 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3925 rcop->op_next = expr;
3926 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3929 rcop->op_next = LINKLIST(expr);
3930 expr->op_next = (OP*)rcop;
3933 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3938 if (pm->op_pmflags & PMf_EVAL) {
3940 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3941 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3943 else if (repl->op_type == OP_CONST)
3947 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3948 if (curop->op_type == OP_SCOPE
3949 || curop->op_type == OP_LEAVE
3950 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3951 if (curop->op_type == OP_GV) {
3952 GV * const gv = cGVOPx_gv(curop);
3954 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3957 else if (curop->op_type == OP_RV2CV)
3959 else if (curop->op_type == OP_RV2SV ||
3960 curop->op_type == OP_RV2AV ||
3961 curop->op_type == OP_RV2HV ||
3962 curop->op_type == OP_RV2GV) {
3963 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3966 else if (curop->op_type == OP_PADSV ||
3967 curop->op_type == OP_PADAV ||
3968 curop->op_type == OP_PADHV ||
3969 curop->op_type == OP_PADANY)
3973 else if (curop->op_type == OP_PUSHRE)
3974 NOOP; /* Okay here, dangerous in newASSIGNOP */
3984 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3986 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3987 op_prepend_elem(o->op_type, scalar(repl), o);
3990 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3991 pm->op_pmflags |= PMf_MAYBE_CONST;
3993 NewOp(1101, rcop, 1, LOGOP);
3994 rcop->op_type = OP_SUBSTCONT;
3995 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3996 rcop->op_first = scalar(repl);
3997 rcop->op_flags |= OPf_KIDS;
3998 rcop->op_private = 1;
4001 /* establish postfix order */
4002 rcop->op_next = LINKLIST(repl);
4003 repl->op_next = (OP*)rcop;
4005 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4006 assert(!(pm->op_pmflags & PMf_ONCE));
4007 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4016 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4018 Constructs, checks, and returns an op of any type that involves an
4019 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4020 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4021 takes ownership of one reference to it.
4027 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4032 PERL_ARGS_ASSERT_NEWSVOP;
4034 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4035 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4036 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4038 NewOp(1101, svop, 1, SVOP);
4039 svop->op_type = (OPCODE)type;
4040 svop->op_ppaddr = PL_ppaddr[type];
4042 svop->op_next = (OP*)svop;
4043 svop->op_flags = (U8)flags;
4044 if (PL_opargs[type] & OA_RETSCALAR)
4046 if (PL_opargs[type] & OA_TARGET)
4047 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4048 return CHECKOP(type, svop);
4054 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4056 Constructs, checks, and returns an op of any type that involves a
4057 reference to a pad element. I<type> is the opcode. I<flags> gives the
4058 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4059 is populated with I<sv>; this function takes ownership of one reference
4062 This function only exists if Perl has been compiled to use ithreads.
4068 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4073 PERL_ARGS_ASSERT_NEWPADOP;
4075 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4076 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4077 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4079 NewOp(1101, padop, 1, PADOP);
4080 padop->op_type = (OPCODE)type;
4081 padop->op_ppaddr = PL_ppaddr[type];
4082 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4083 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4084 PAD_SETSV(padop->op_padix, sv);
4087 padop->op_next = (OP*)padop;
4088 padop->op_flags = (U8)flags;
4089 if (PL_opargs[type] & OA_RETSCALAR)
4091 if (PL_opargs[type] & OA_TARGET)
4092 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4093 return CHECKOP(type, padop);
4096 #endif /* !USE_ITHREADS */
4099 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4101 Constructs, checks, and returns an op of any type that involves an
4102 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4103 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4104 reference; calling this function does not transfer ownership of any
4111 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4115 PERL_ARGS_ASSERT_NEWGVOP;
4119 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4121 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4126 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4128 Constructs, checks, and returns an op of any type that involves an
4129 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4130 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4131 must have been allocated using L</PerlMemShared_malloc>; the memory will
4132 be freed when the op is destroyed.
4138 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4143 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4144 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4146 NewOp(1101, pvop, 1, PVOP);
4147 pvop->op_type = (OPCODE)type;
4148 pvop->op_ppaddr = PL_ppaddr[type];
4150 pvop->op_next = (OP*)pvop;
4151 pvop->op_flags = (U8)flags;
4152 if (PL_opargs[type] & OA_RETSCALAR)
4154 if (PL_opargs[type] & OA_TARGET)
4155 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4156 return CHECKOP(type, pvop);
4164 Perl_package(pTHX_ OP *o)
4167 SV *const sv = cSVOPo->op_sv;
4172 PERL_ARGS_ASSERT_PACKAGE;
4174 save_hptr(&PL_curstash);
4175 save_item(PL_curstname);
4177 PL_curstash = gv_stashsv(sv, GV_ADD);
4179 sv_setsv(PL_curstname, sv);
4181 PL_hints |= HINT_BLOCK_SCOPE;
4182 PL_parser->copline = NOLINE;
4183 PL_parser->expect = XSTATE;
4188 if (!PL_madskills) {
4193 pegop = newOP(OP_NULL,0);
4194 op_getmad(o,pegop,'P');
4200 Perl_package_version( pTHX_ OP *v )
4203 U32 savehints = PL_hints;
4204 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4205 PL_hints &= ~HINT_STRICT_VARS;
4206 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4207 PL_hints = savehints;
4216 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4223 OP *pegop = newOP(OP_NULL,0);
4225 SV *use_version = NULL;
4227 PERL_ARGS_ASSERT_UTILIZE;
4229 if (idop->op_type != OP_CONST)
4230 Perl_croak(aTHX_ "Module name must be constant");
4233 op_getmad(idop,pegop,'U');
4238 SV * const vesv = ((SVOP*)version)->op_sv;
4241 op_getmad(version,pegop,'V');
4242 if (!arg && !SvNIOKp(vesv)) {
4249 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4250 Perl_croak(aTHX_ "Version number must be a constant number");
4252 /* Make copy of idop so we don't free it twice */
4253 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4255 /* Fake up a method call to VERSION */
4256 meth = newSVpvs_share("VERSION");
4257 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4258 op_append_elem(OP_LIST,
4259 op_prepend_elem(OP_LIST, pack, list(version)),
4260 newSVOP(OP_METHOD_NAMED, 0, meth)));
4264 /* Fake up an import/unimport */
4265 if (arg && arg->op_type == OP_STUB) {
4267 op_getmad(arg,pegop,'S');
4268 imop = arg; /* no import on explicit () */
4270 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4271 imop = NULL; /* use 5.0; */
4273 use_version = ((SVOP*)idop)->op_sv;
4275 idop->op_private |= OPpCONST_NOVER;
4281 op_getmad(arg,pegop,'A');
4283 /* Make copy of idop so we don't free it twice */
4284 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4286 /* Fake up a method call to import/unimport */
4288 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4289 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4290 op_append_elem(OP_LIST,
4291 op_prepend_elem(OP_LIST, pack, list(arg)),
4292 newSVOP(OP_METHOD_NAMED, 0, meth)));
4295 /* Fake up the BEGIN {}, which does its thing immediately. */
4297 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4300 op_append_elem(OP_LINESEQ,
4301 op_append_elem(OP_LINESEQ,
4302 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4303 newSTATEOP(0, NULL, veop)),
4304 newSTATEOP(0, NULL, imop) ));
4307 /* If we request a version >= 5.9.5, load feature.pm with the
4308 * feature bundle that corresponds to the required version. */
4309 use_version = sv_2mortal(new_version(use_version));
4311 if (vcmp(use_version,
4312 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4313 SV *const importsv = vnormal(use_version);
4314 *SvPVX_mutable(importsv) = ':';
4315 ENTER_with_name("load_feature");
4316 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4317 LEAVE_with_name("load_feature");
4319 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4320 if (vcmp(use_version,
4321 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4322 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4326 /* The "did you use incorrect case?" warning used to be here.
4327 * The problem is that on case-insensitive filesystems one
4328 * might get false positives for "use" (and "require"):
4329 * "use Strict" or "require CARP" will work. This causes
4330 * portability problems for the script: in case-strict
4331 * filesystems the script will stop working.
4333 * The "incorrect case" warning checked whether "use Foo"
4334 * imported "Foo" to your namespace, but that is wrong, too:
4335 * there is no requirement nor promise in the language that
4336 * a Foo.pm should or would contain anything in package "Foo".
4338 * There is very little Configure-wise that can be done, either:
4339 * the case-sensitivity of the build filesystem of Perl does not
4340 * help in guessing the case-sensitivity of the runtime environment.
4343 PL_hints |= HINT_BLOCK_SCOPE;
4344 PL_parser->copline = NOLINE;
4345 PL_parser->expect = XSTATE;
4346 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4349 if (!PL_madskills) {
4350 /* FIXME - don't allocate pegop if !PL_madskills */
4359 =head1 Embedding Functions
4361 =for apidoc load_module
4363 Loads the module whose name is pointed to by the string part of name.
4364 Note that the actual module name, not its filename, should be given.
4365 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4366 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4367 (or 0 for no flags). ver, if specified, provides version semantics
4368 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4369 arguments can be used to specify arguments to the module's import()
4370 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4371 terminated with a final NULL pointer. Note that this list can only
4372 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4373 Otherwise at least a single NULL pointer to designate the default
4374 import list is required.
4379 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4383 PERL_ARGS_ASSERT_LOAD_MODULE;
4385 va_start(args, ver);
4386 vload_module(flags, name, ver, &args);
4390 #ifdef PERL_IMPLICIT_CONTEXT
4392 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4396 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4397 va_start(args, ver);
4398 vload_module(flags, name, ver, &args);
4404 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4408 OP * const modname = newSVOP(OP_CONST, 0, name);
4410 PERL_ARGS_ASSERT_VLOAD_MODULE;
4412 modname->op_private |= OPpCONST_BARE;
4414 veop = newSVOP(OP_CONST, 0, ver);
4418 if (flags & PERL_LOADMOD_NOIMPORT) {
4419 imop = sawparens(newNULLLIST());
4421 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4422 imop = va_arg(*args, OP*);
4427 sv = va_arg(*args, SV*);
4429 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4430 sv = va_arg(*args, SV*);
4434 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4435 * that it has a PL_parser to play with while doing that, and also
4436 * that it doesn't mess with any existing parser, by creating a tmp
4437 * new parser with lex_start(). This won't actually be used for much,
4438 * since pp_require() will create another parser for the real work. */
4441 SAVEVPTR(PL_curcop);
4442 lex_start(NULL, NULL, 0);
4443 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4444 veop, modname, imop);
4449 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4455 PERL_ARGS_ASSERT_DOFILE;
4457 if (!force_builtin) {
4458 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4459 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4460 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4461 gv = gvp ? *gvp : NULL;
4465 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4466 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4467 op_append_elem(OP_LIST, term,
4468 scalar(newUNOP(OP_RV2CV, 0,
4469 newGVOP(OP_GV, 0, gv))))));
4472 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4478 =head1 Optree construction
4480 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4482 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4483 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4484 be set automatically, and, shifted up eight bits, the eight bits of
4485 C<op_private>, except that the bit with value 1 or 2 is automatically
4486 set as required. I<listval> and I<subscript> supply the parameters of
4487 the slice; they are consumed by this function and become part of the
4488 constructed op tree.
4494 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4496 return newBINOP(OP_LSLICE, flags,
4497 list(force_list(subscript)),
4498 list(force_list(listval)) );
4502 S_is_list_assignment(pTHX_ register const OP *o)
4510 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4511 o = cUNOPo->op_first;
4513 flags = o->op_flags;
4515 if (type == OP_COND_EXPR) {
4516 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4517 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4522 yyerror("Assignment to both a list and a scalar");
4526 if (type == OP_LIST &&
4527 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4528 o->op_private & OPpLVAL_INTRO)
4531 if (type == OP_LIST || flags & OPf_PARENS ||
4532 type == OP_RV2AV || type == OP_RV2HV ||
4533 type == OP_ASLICE || type == OP_HSLICE)
4536 if (type == OP_PADAV || type == OP_PADHV)
4539 if (type == OP_RV2SV)
4546 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4548 Constructs, checks, and returns an assignment op. I<left> and I<right>
4549 supply the parameters of the assignment; they are consumed by this
4550 function and become part of the constructed op tree.
4552 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4553 a suitable conditional optree is constructed. If I<optype> is the opcode
4554 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4555 performs the binary operation and assigns the result to the left argument.
4556 Either way, if I<optype> is non-zero then I<flags> has no effect.
4558 If I<optype> is zero, then a plain scalar or list assignment is
4559 constructed. Which type of assignment it is is automatically determined.
4560 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4561 will be set automatically, and, shifted up eight bits, the eight bits
4562 of C<op_private>, except that the bit with value 1 or 2 is automatically
4569 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4575 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4576 return newLOGOP(optype, 0,
4577 op_lvalue(scalar(left), optype),
4578 newUNOP(OP_SASSIGN, 0, scalar(right)));
4581 return newBINOP(optype, OPf_STACKED,
4582 op_lvalue(scalar(left), optype), scalar(right));
4586 if (is_list_assignment(left)) {
4587 static const char no_list_state[] = "Initialization of state variables"
4588 " in list context currently forbidden";
4590 bool maybe_common_vars = TRUE;
4593 /* Grandfathering $[ assignment here. Bletch.*/
4594 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4595 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4596 left = op_lvalue(left, OP_AASSIGN);
4599 else if (left->op_type == OP_CONST) {
4600 deprecate("assignment to $[");
4602 /* Result of assignment is always 1 (or we'd be dead already) */
4603 return newSVOP(OP_CONST, 0, newSViv(1));
4605 curop = list(force_list(left));
4606 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4607 o->op_private = (U8)(0 | (flags >> 8));
4609 if ((left->op_type == OP_LIST
4610 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4612 OP* lop = ((LISTOP*)left)->op_first;
4613 maybe_common_vars = FALSE;
4615 if (lop->op_type == OP_PADSV ||
4616 lop->op_type == OP_PADAV ||
4617 lop->op_type == OP_PADHV ||
4618 lop->op_type == OP_PADANY) {
4619 if (!(lop->op_private & OPpLVAL_INTRO))
4620 maybe_common_vars = TRUE;
4622 if (lop->op_private & OPpPAD_STATE) {
4623 if (left->op_private & OPpLVAL_INTRO) {
4624 /* Each variable in state($a, $b, $c) = ... */
4627 /* Each state variable in
4628 (state $a, my $b, our $c, $d, undef) = ... */
4630 yyerror(no_list_state);
4632 /* Each my variable in
4633 (state $a, my $b, our $c, $d, undef) = ... */
4635 } else if (lop->op_type == OP_UNDEF ||
4636 lop->op_type == OP_PUSHMARK) {
4637 /* undef may be interesting in
4638 (state $a, undef, state $c) */
4640 /* Other ops in the list. */
4641 maybe_common_vars = TRUE;
4643 lop = lop->op_sibling;
4646 else if ((left->op_private & OPpLVAL_INTRO)
4647 && ( left->op_type == OP_PADSV
4648 || left->op_type == OP_PADAV
4649 || left->op_type == OP_PADHV
4650 || left->op_type == OP_PADANY))
4652 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4653 if (left->op_private & OPpPAD_STATE) {
4654 /* All single variable list context state assignments, hence
4664 yyerror(no_list_state);
4668 /* PL_generation sorcery:
4669 * an assignment like ($a,$b) = ($c,$d) is easier than
4670 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4671 * To detect whether there are common vars, the global var
4672 * PL_generation is incremented for each assign op we compile.
4673 * Then, while compiling the assign op, we run through all the
4674 * variables on both sides of the assignment, setting a spare slot
4675 * in each of them to PL_generation. If any of them already have
4676 * that value, we know we've got commonality. We could use a
4677 * single bit marker, but then we'd have to make 2 passes, first
4678 * to clear the flag, then to test and set it. To find somewhere
4679 * to store these values, evil chicanery is done with SvUVX().
4682 if (maybe_common_vars) {
4685 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4686 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4687 if (curop->op_type == OP_GV) {
4688 GV *gv = cGVOPx_gv(curop);
4690 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4692 GvASSIGN_GENERATION_set(gv, PL_generation);
4694 else if (curop->op_type == OP_PADSV ||
4695 curop->op_type == OP_PADAV ||
4696 curop->op_type == OP_PADHV ||
4697 curop->op_type == OP_PADANY)
4699 if (PAD_COMPNAME_GEN(curop->op_targ)
4700 == (STRLEN)PL_generation)
4702 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4705 else if (curop->op_type == OP_RV2CV)
4707 else if (curop->op_type == OP_RV2SV ||
4708 curop->op_type == OP_RV2AV ||
4709 curop->op_type == OP_RV2HV ||
4710 curop->op_type == OP_RV2GV) {
4711 if (lastop->op_type != OP_GV) /* funny deref? */
4714 else if (curop->op_type == OP_PUSHRE) {
4716 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4717 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4719 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4721 GvASSIGN_GENERATION_set(gv, PL_generation);
4725 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4728 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4730 GvASSIGN_GENERATION_set(gv, PL_generation);
4740 o->op_private |= OPpASSIGN_COMMON;
4743 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4744 OP* tmpop = ((LISTOP*)right)->op_first;
4745 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4746 PMOP * const pm = (PMOP*)tmpop;
4747 if (left->op_type == OP_RV2AV &&
4748 !(left->op_private & OPpLVAL_INTRO) &&
4749 !(o->op_private & OPpASSIGN_COMMON) )
4751 tmpop = ((UNOP*)left)->op_first;
4752 if (tmpop->op_type == OP_GV
4754 && !pm->op_pmreplrootu.op_pmtargetoff
4756 && !pm->op_pmreplrootu.op_pmtargetgv
4760 pm->op_pmreplrootu.op_pmtargetoff
4761 = cPADOPx(tmpop)->op_padix;
4762 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4764 pm->op_pmreplrootu.op_pmtargetgv
4765 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4766 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4768 pm->op_pmflags |= PMf_ONCE;
4769 tmpop = cUNOPo->op_first; /* to list (nulled) */
4770 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4771 tmpop->op_sibling = NULL; /* don't free split */
4772 right->op_next = tmpop->op_next; /* fix starting loc */
4773 op_free(o); /* blow off assign */
4774 right->op_flags &= ~OPf_WANT;
4775 /* "I don't know and I don't care." */
4780 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4781 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4783 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4784 if (SvIOK(sv) && SvIVX(sv) == 0)
4785 sv_setiv(sv, PL_modcount+1);
4793 right = newOP(OP_UNDEF, 0);
4794 if (right->op_type == OP_READLINE) {
4795 right->op_flags |= OPf_STACKED;
4796 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4800 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4801 o = newBINOP(OP_SASSIGN, flags,
4802 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4806 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4807 deprecate("assignment to $[");
4809 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4810 o->op_private |= OPpCONST_ARYBASE;
4818 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4820 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4821 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4822 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4823 If I<label> is non-null, it supplies the name of a label to attach to
4824 the state op; this function takes ownership of the memory pointed at by
4825 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4828 If I<o> is null, the state op is returned. Otherwise the state op is
4829 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4830 is consumed by this function and becomes part of the returned op tree.
4836 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4839 const U32 seq = intro_my();
4842 NewOp(1101, cop, 1, COP);
4843 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4844 cop->op_type = OP_DBSTATE;
4845 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4848 cop->op_type = OP_NEXTSTATE;
4849 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4851 cop->op_flags = (U8)flags;
4852 CopHINTS_set(cop, PL_hints);
4854 cop->op_private |= NATIVE_HINTS;
4856 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4857 cop->op_next = (OP*)cop;
4860 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4861 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4863 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4864 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4866 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4868 PL_hints |= HINT_BLOCK_SCOPE;
4869 /* It seems that we need to defer freeing this pointer, as other parts
4870 of the grammar end up wanting to copy it after this op has been
4875 if (PL_parser && PL_parser->copline == NOLINE)
4876 CopLINE_set(cop, CopLINE(PL_curcop));
4878 CopLINE_set(cop, PL_parser->copline);
4880 PL_parser->copline = NOLINE;
4883 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4885 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4887 CopSTASH_set(cop, PL_curstash);
4889 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4890 /* this line can have a breakpoint - store the cop in IV */
4891 AV *av = CopFILEAVx(PL_curcop);
4893 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4894 if (svp && *svp != &PL_sv_undef ) {
4895 (void)SvIOK_on(*svp);
4896 SvIV_set(*svp, PTR2IV(cop));
4901 if (flags & OPf_SPECIAL)
4903 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4907 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4909 Constructs, checks, and returns a logical (flow control) op. I<type>
4910 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4911 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4912 the eight bits of C<op_private>, except that the bit with value 1 is
4913 automatically set. I<first> supplies the expression controlling the
4914 flow, and I<other> supplies the side (alternate) chain of ops; they are
4915 consumed by this function and become part of the constructed op tree.
4921 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4925 PERL_ARGS_ASSERT_NEWLOGOP;
4927 return new_logop(type, flags, &first, &other);
4931 S_search_const(pTHX_ OP *o)
4933 PERL_ARGS_ASSERT_SEARCH_CONST;
4935 switch (o->op_type) {
4939 if (o->op_flags & OPf_KIDS)
4940 return search_const(cUNOPo->op_first);
4947 if (!(o->op_flags & OPf_KIDS))
4949 kid = cLISTOPo->op_first;
4951 switch (kid->op_type) {
4955 kid = kid->op_sibling;
4958 if (kid != cLISTOPo->op_last)
4964 kid = cLISTOPo->op_last;
4966 return search_const(kid);
4974 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4982 int prepend_not = 0;
4984 PERL_ARGS_ASSERT_NEW_LOGOP;
4989 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4990 return newBINOP(type, flags, scalar(first), scalar(other));
4992 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4994 scalarboolean(first);
4995 /* optimize AND and OR ops that have NOTs as children */
4996 if (first->op_type == OP_NOT
4997 && (first->op_flags & OPf_KIDS)
4998 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4999 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5001 if (type == OP_AND || type == OP_OR) {
5007 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5009 prepend_not = 1; /* prepend a NOT op later */
5013 /* search for a constant op that could let us fold the test */
5014 if ((cstop = search_const(first))) {
5015 if (cstop->op_private & OPpCONST_STRICT)
5016 no_bareword_allowed(cstop);
5017 else if ((cstop->op_private & OPpCONST_BARE))
5018 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5019 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5020 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5021 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5023 if (other->op_type == OP_CONST)
5024 other->op_private |= OPpCONST_SHORTCIRCUIT;
5026 OP *newop = newUNOP(OP_NULL, 0, other);
5027 op_getmad(first, newop, '1');
5028 newop->op_targ = type; /* set "was" field */
5032 if (other->op_type == OP_LEAVE)
5033 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5034 else if (other->op_type == OP_MATCH
5035 || other->op_type == OP_SUBST
5036 || other->op_type == OP_TRANSR
5037 || other->op_type == OP_TRANS)
5038 /* Mark the op as being unbindable with =~ */
5039 other->op_flags |= OPf_SPECIAL;
5043 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5044 const OP *o2 = other;
5045 if ( ! (o2->op_type == OP_LIST
5046 && (( o2 = cUNOPx(o2)->op_first))
5047 && o2->op_type == OP_PUSHMARK
5048 && (( o2 = o2->op_sibling)) )
5051 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5052 || o2->op_type == OP_PADHV)
5053 && o2->op_private & OPpLVAL_INTRO
5054 && !(o2->op_private & OPpPAD_STATE))
5056 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5057 "Deprecated use of my() in false conditional");
5061 if (first->op_type == OP_CONST)
5062 first->op_private |= OPpCONST_SHORTCIRCUIT;
5064 first = newUNOP(OP_NULL, 0, first);
5065 op_getmad(other, first, '2');
5066 first->op_targ = type; /* set "was" field */
5073 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5074 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5076 const OP * const k1 = ((UNOP*)first)->op_first;
5077 const OP * const k2 = k1->op_sibling;
5079 switch (first->op_type)
5082 if (k2 && k2->op_type == OP_READLINE
5083 && (k2->op_flags & OPf_STACKED)
5084 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5086 warnop = k2->op_type;
5091 if (k1->op_type == OP_READDIR
5092 || k1->op_type == OP_GLOB
5093 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5094 || k1->op_type == OP_EACH)
5096 warnop = ((k1->op_type == OP_NULL)
5097 ? (OPCODE)k1->op_targ : k1->op_type);
5102 const line_t oldline = CopLINE(PL_curcop);
5103 CopLINE_set(PL_curcop, PL_parser->copline);
5104 Perl_warner(aTHX_ packWARN(WARN_MISC),
5105 "Value of %s%s can be \"0\"; test with defined()",
5107 ((warnop == OP_READLINE || warnop == OP_GLOB)
5108 ? " construct" : "() operator"));
5109 CopLINE_set(PL_curcop, oldline);
5116 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5117 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5119 NewOp(1101, logop, 1, LOGOP);
5121 logop->op_type = (OPCODE)type;
5122 logop->op_ppaddr = PL_ppaddr[type];
5123 logop->op_first = first;
5124 logop->op_flags = (U8)(flags | OPf_KIDS);
5125 logop->op_other = LINKLIST(other);
5126 logop->op_private = (U8)(1 | (flags >> 8));
5128 /* establish postfix order */
5129 logop->op_next = LINKLIST(first);
5130 first->op_next = (OP*)logop;
5131 first->op_sibling = other;
5133 CHECKOP(type,logop);
5135 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5142 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5144 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5145 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5146 will be set automatically, and, shifted up eight bits, the eight bits of
5147 C<op_private>, except that the bit with value 1 is automatically set.
5148 I<first> supplies the expression selecting between the two branches,
5149 and I<trueop> and I<falseop> supply the branches; they are consumed by
5150 this function and become part of the constructed op tree.
5156 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5164 PERL_ARGS_ASSERT_NEWCONDOP;
5167 return newLOGOP(OP_AND, 0, first, trueop);
5169 return newLOGOP(OP_OR, 0, first, falseop);
5171 scalarboolean(first);
5172 if ((cstop = search_const(first))) {
5173 /* Left or right arm of the conditional? */
5174 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5175 OP *live = left ? trueop : falseop;
5176 OP *const dead = left ? falseop : trueop;
5177 if (cstop->op_private & OPpCONST_BARE &&
5178 cstop->op_private & OPpCONST_STRICT) {
5179 no_bareword_allowed(cstop);
5182 /* This is all dead code when PERL_MAD is not defined. */
5183 live = newUNOP(OP_NULL, 0, live);
5184 op_getmad(first, live, 'C');
5185 op_getmad(dead, live, left ? 'e' : 't');
5190 if (live->op_type == OP_LEAVE)
5191 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5192 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5193 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5194 /* Mark the op as being unbindable with =~ */
5195 live->op_flags |= OPf_SPECIAL;
5198 NewOp(1101, logop, 1, LOGOP);
5199 logop->op_type = OP_COND_EXPR;
5200 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5201 logop->op_first = first;
5202 logop->op_flags = (U8)(flags | OPf_KIDS);
5203 logop->op_private = (U8)(1 | (flags >> 8));
5204 logop->op_other = LINKLIST(trueop);
5205 logop->op_next = LINKLIST(falseop);
5207 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5210 /* establish postfix order */
5211 start = LINKLIST(first);
5212 first->op_next = (OP*)logop;
5214 first->op_sibling = trueop;
5215 trueop->op_sibling = falseop;
5216 o = newUNOP(OP_NULL, 0, (OP*)logop);
5218 trueop->op_next = falseop->op_next = o;
5225 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5227 Constructs and returns a C<range> op, with subordinate C<flip> and
5228 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5229 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5230 for both the C<flip> and C<range> ops, except that the bit with value
5231 1 is automatically set. I<left> and I<right> supply the expressions
5232 controlling the endpoints of the range; they are consumed by this function
5233 and become part of the constructed op tree.
5239 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5248 PERL_ARGS_ASSERT_NEWRANGE;
5250 NewOp(1101, range, 1, LOGOP);
5252 range->op_type = OP_RANGE;
5253 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5254 range->op_first = left;
5255 range->op_flags = OPf_KIDS;
5256 leftstart = LINKLIST(left);
5257 range->op_other = LINKLIST(right);
5258 range->op_private = (U8)(1 | (flags >> 8));
5260 left->op_sibling = right;
5262 range->op_next = (OP*)range;
5263 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5264 flop = newUNOP(OP_FLOP, 0, flip);
5265 o = newUNOP(OP_NULL, 0, flop);
5267 range->op_next = leftstart;
5269 left->op_next = flip;
5270 right->op_next = flop;
5272 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5273 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5274 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5275 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5277 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5278 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5281 if (!flip->op_private || !flop->op_private)
5282 LINKLIST(o); /* blow off optimizer unless constant */
5288 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5290 Constructs, checks, and returns an op tree expressing a loop. This is
5291 only a loop in the control flow through the op tree; it does not have
5292 the heavyweight loop structure that allows exiting the loop by C<last>
5293 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5294 top-level op, except that some bits will be set automatically as required.
5295 I<expr> supplies the expression controlling loop iteration, and I<block>
5296 supplies the body of the loop; they are consumed by this function and
5297 become part of the constructed op tree. I<debuggable> is currently
5298 unused and should always be 1.
5304 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5309 const bool once = block && block->op_flags & OPf_SPECIAL &&
5310 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5312 PERL_UNUSED_ARG(debuggable);
5315 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5316 return block; /* do {} while 0 does once */
5317 if (expr->op_type == OP_READLINE
5318 || expr->op_type == OP_READDIR
5319 || expr->op_type == OP_GLOB
5320 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5321 expr = newUNOP(OP_DEFINED, 0,
5322 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5323 } else if (expr->op_flags & OPf_KIDS) {
5324 const OP * const k1 = ((UNOP*)expr)->op_first;
5325 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5326 switch (expr->op_type) {
5328 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5329 && (k2->op_flags & OPf_STACKED)
5330 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5331 expr = newUNOP(OP_DEFINED, 0, expr);
5335 if (k1 && (k1->op_type == OP_READDIR
5336 || k1->op_type == OP_GLOB
5337 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5338 || k1->op_type == OP_EACH))
5339 expr = newUNOP(OP_DEFINED, 0, expr);
5345 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5346 * op, in listop. This is wrong. [perl #27024] */
5348 block = newOP(OP_NULL, 0);
5349 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5350 o = new_logop(OP_AND, 0, &expr, &listop);
5353 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5355 if (once && o != listop)
5356 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5359 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5361 o->op_flags |= flags;
5363 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5368 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5370 Constructs, checks, and returns an op tree expressing a C<while> loop.
5371 This is a heavyweight loop, with structure that allows exiting the loop
5372 by C<last> and suchlike.
5374 I<loop> is an optional preconstructed C<enterloop> op to use in the
5375 loop; if it is null then a suitable op will be constructed automatically.
5376 I<expr> supplies the loop's controlling expression. I<block> supplies the
5377 main body of the loop, and I<cont> optionally supplies a C<continue> block
5378 that operates as a second half of the body. All of these optree inputs
5379 are consumed by this function and become part of the constructed op tree.
5381 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5382 op and, shifted up eight bits, the eight bits of C<op_private> for
5383 the C<leaveloop> op, except that (in both cases) some bits will be set
5384 automatically. I<debuggable> is currently unused and should always be 1.
5385 I<has_my> can be supplied as true to force the
5386 loop body to be enclosed in its own scope.
5392 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5393 OP *expr, OP *block, OP *cont, I32 has_my)
5402 PERL_UNUSED_ARG(debuggable);
5405 if (expr->op_type == OP_READLINE
5406 || expr->op_type == OP_READDIR
5407 || expr->op_type == OP_GLOB
5408 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5409 expr = newUNOP(OP_DEFINED, 0,
5410 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5411 } else if (expr->op_flags & OPf_KIDS) {
5412 const OP * const k1 = ((UNOP*)expr)->op_first;
5413 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5414 switch (expr->op_type) {
5416 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5417 && (k2->op_flags & OPf_STACKED)
5418 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5419 expr = newUNOP(OP_DEFINED, 0, expr);
5423 if (k1 && (k1->op_type == OP_READDIR
5424 || k1->op_type == OP_GLOB
5425 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5426 || k1->op_type == OP_EACH))
5427 expr = newUNOP(OP_DEFINED, 0, expr);
5434 block = newOP(OP_NULL, 0);
5435 else if (cont || has_my) {
5436 block = op_scope(block);
5440 next = LINKLIST(cont);
5443 OP * const unstack = newOP(OP_UNSTACK, 0);
5446 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5450 listop = op_append_list(OP_LINESEQ, block, cont);
5452 redo = LINKLIST(listop);
5456 o = new_logop(OP_AND, 0, &expr, &listop);
5457 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5458 op_free(expr); /* oops, it's a while (0) */
5460 return NULL; /* listop already freed by new_logop */
5463 ((LISTOP*)listop)->op_last->op_next =
5464 (o == listop ? redo : LINKLIST(o));
5470 NewOp(1101,loop,1,LOOP);
5471 loop->op_type = OP_ENTERLOOP;
5472 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5473 loop->op_private = 0;
5474 loop->op_next = (OP*)loop;
5477 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5479 loop->op_redoop = redo;
5480 loop->op_lastop = o;
5481 o->op_private |= loopflags;
5484 loop->op_nextop = next;
5486 loop->op_nextop = o;
5488 o->op_flags |= flags;
5489 o->op_private |= (flags >> 8);
5494 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5496 Constructs, checks, and returns an op tree expressing a C<foreach>
5497 loop (iteration through a list of values). This is a heavyweight loop,
5498 with structure that allows exiting the loop by C<last> and suchlike.
5500 I<sv> optionally supplies the variable that will be aliased to each
5501 item in turn; if null, it defaults to C<$_> (either lexical or global).
5502 I<expr> supplies the list of values to iterate over. I<block> supplies
5503 the main body of the loop, and I<cont> optionally supplies a C<continue>
5504 block that operates as a second half of the body. All of these optree
5505 inputs are consumed by this function and become part of the constructed
5508 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5509 op and, shifted up eight bits, the eight bits of C<op_private> for
5510 the C<leaveloop> op, except that (in both cases) some bits will be set
5517 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5522 PADOFFSET padoff = 0;
5527 PERL_ARGS_ASSERT_NEWFOROP;
5530 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5531 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5532 sv->op_type = OP_RV2GV;
5533 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5535 /* The op_type check is needed to prevent a possible segfault
5536 * if the loop variable is undeclared and 'strict vars' is in
5537 * effect. This is illegal but is nonetheless parsed, so we
5538 * may reach this point with an OP_CONST where we're expecting
5541 if (cUNOPx(sv)->op_first->op_type == OP_GV
5542 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5543 iterpflags |= OPpITER_DEF;
5545 else if (sv->op_type == OP_PADSV) { /* private variable */
5546 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5547 padoff = sv->op_targ;
5557 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5559 SV *const namesv = PAD_COMPNAME_SV(padoff);
5561 const char *const name = SvPV_const(namesv, len);
5563 if (len == 2 && name[0] == '$' && name[1] == '_')
5564 iterpflags |= OPpITER_DEF;
5568 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5569 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5570 sv = newGVOP(OP_GV, 0, PL_defgv);
5575 iterpflags |= OPpITER_DEF;
5577 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5578 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5579 iterflags |= OPf_STACKED;
5581 else if (expr->op_type == OP_NULL &&
5582 (expr->op_flags & OPf_KIDS) &&
5583 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5585 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5586 * set the STACKED flag to indicate that these values are to be
5587 * treated as min/max values by 'pp_iterinit'.
5589 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5590 LOGOP* const range = (LOGOP*) flip->op_first;
5591 OP* const left = range->op_first;
5592 OP* const right = left->op_sibling;
5595 range->op_flags &= ~OPf_KIDS;
5596 range->op_first = NULL;
5598 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5599 listop->op_first->op_next = range->op_next;
5600 left->op_next = range->op_other;
5601 right->op_next = (OP*)listop;
5602 listop->op_next = listop->op_first;
5605 op_getmad(expr,(OP*)listop,'O');
5609 expr = (OP*)(listop);
5611 iterflags |= OPf_STACKED;
5614 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5617 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5618 op_append_elem(OP_LIST, expr, scalar(sv))));
5619 assert(!loop->op_next);
5620 /* for my $x () sets OPpLVAL_INTRO;
5621 * for our $x () sets OPpOUR_INTRO */
5622 loop->op_private = (U8)iterpflags;
5623 #ifdef PL_OP_SLAB_ALLOC
5626 NewOp(1234,tmp,1,LOOP);
5627 Copy(loop,tmp,1,LISTOP);
5628 S_op_destroy(aTHX_ (OP*)loop);
5632 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5634 loop->op_targ = padoff;
5635 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5637 op_getmad(madsv, (OP*)loop, 'v');
5642 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5644 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5645 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5646 determining the target of the op; it is consumed by this function and
5647 become part of the constructed op tree.
5653 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5658 PERL_ARGS_ASSERT_NEWLOOPEX;
5660 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5662 if (type != OP_GOTO || label->op_type == OP_CONST) {
5663 /* "last()" means "last" */
5664 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5665 o = newOP(type, OPf_SPECIAL);
5667 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5668 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5672 op_getmad(label,o,'L');
5678 /* Check whether it's going to be a goto &function */
5679 if (label->op_type == OP_ENTERSUB
5680 && !(label->op_flags & OPf_STACKED))
5681 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5682 o = newUNOP(type, OPf_STACKED, label);
5684 PL_hints |= HINT_BLOCK_SCOPE;
5688 /* if the condition is a literal array or hash
5689 (or @{ ... } etc), make a reference to it.
5692 S_ref_array_or_hash(pTHX_ OP *cond)
5695 && (cond->op_type == OP_RV2AV
5696 || cond->op_type == OP_PADAV
5697 || cond->op_type == OP_RV2HV
5698 || cond->op_type == OP_PADHV))
5700 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5703 && (cond->op_type == OP_ASLICE
5704 || cond->op_type == OP_HSLICE)) {
5706 /* anonlist now needs a list from this op, was previously used in
5708 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5709 cond->op_flags |= OPf_WANT_LIST;
5711 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5718 /* These construct the optree fragments representing given()
5721 entergiven and enterwhen are LOGOPs; the op_other pointer
5722 points up to the associated leave op. We need this so we
5723 can put it in the context and make break/continue work.
5724 (Also, of course, pp_enterwhen will jump straight to
5725 op_other if the match fails.)
5729 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5730 I32 enter_opcode, I32 leave_opcode,
5731 PADOFFSET entertarg)
5737 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5739 NewOp(1101, enterop, 1, LOGOP);
5740 enterop->op_type = (Optype)enter_opcode;
5741 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5742 enterop->op_flags = (U8) OPf_KIDS;
5743 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5744 enterop->op_private = 0;
5746 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5749 enterop->op_first = scalar(cond);
5750 cond->op_sibling = block;
5752 o->op_next = LINKLIST(cond);
5753 cond->op_next = (OP *) enterop;
5756 /* This is a default {} block */
5757 enterop->op_first = block;
5758 enterop->op_flags |= OPf_SPECIAL;
5760 o->op_next = (OP *) enterop;
5763 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5764 entergiven and enterwhen both
5767 enterop->op_next = LINKLIST(block);
5768 block->op_next = enterop->op_other = o;
5773 /* Does this look like a boolean operation? For these purposes
5774 a boolean operation is:
5775 - a subroutine call [*]
5776 - a logical connective
5777 - a comparison operator
5778 - a filetest operator, with the exception of -s -M -A -C
5779 - defined(), exists() or eof()
5780 - /$re/ or $foo =~ /$re/
5782 [*] possibly surprising
5785 S_looks_like_bool(pTHX_ const OP *o)
5789 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5791 switch(o->op_type) {
5794 return looks_like_bool(cLOGOPo->op_first);
5798 looks_like_bool(cLOGOPo->op_first)
5799 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5804 o->op_flags & OPf_KIDS
5805 && looks_like_bool(cUNOPo->op_first));
5809 case OP_NOT: case OP_XOR:
5811 case OP_EQ: case OP_NE: case OP_LT:
5812 case OP_GT: case OP_LE: case OP_GE:
5814 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5815 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5817 case OP_SEQ: case OP_SNE: case OP_SLT:
5818 case OP_SGT: case OP_SLE: case OP_SGE:
5822 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5823 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5824 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5825 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5826 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5827 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5828 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5829 case OP_FTTEXT: case OP_FTBINARY:
5831 case OP_DEFINED: case OP_EXISTS:
5832 case OP_MATCH: case OP_EOF:
5839 /* Detect comparisons that have been optimized away */
5840 if (cSVOPo->op_sv == &PL_sv_yes
5841 || cSVOPo->op_sv == &PL_sv_no)
5854 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5856 Constructs, checks, and returns an op tree expressing a C<given> block.
5857 I<cond> supplies the expression that will be locally assigned to a lexical
5858 variable, and I<block> supplies the body of the C<given> construct; they
5859 are consumed by this function and become part of the constructed op tree.
5860 I<defsv_off> is the pad offset of the scalar lexical variable that will
5867 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5870 PERL_ARGS_ASSERT_NEWGIVENOP;
5871 return newGIVWHENOP(
5872 ref_array_or_hash(cond),
5874 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5879 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5881 Constructs, checks, and returns an op tree expressing a C<when> block.
5882 I<cond> supplies the test expression, and I<block> supplies the block
5883 that will be executed if the test evaluates to true; they are consumed
5884 by this function and become part of the constructed op tree. I<cond>
5885 will be interpreted DWIMically, often as a comparison against C<$_>,
5886 and may be null to generate a C<default> block.
5892 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5894 const bool cond_llb = (!cond || looks_like_bool(cond));
5897 PERL_ARGS_ASSERT_NEWWHENOP;
5902 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5904 scalar(ref_array_or_hash(cond)));
5907 return newGIVWHENOP(
5909 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5910 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5914 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5917 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5919 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5920 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5921 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5922 || (p && (len != SvCUR(cv) /* Not the same length. */
5923 || memNE(p, SvPVX_const(cv), len))))
5924 && ckWARN_d(WARN_PROTOTYPE)) {
5925 SV* const msg = sv_newmortal();
5929 gv_efullname3(name = sv_newmortal(), gv, NULL);
5930 sv_setpvs(msg, "Prototype mismatch:");
5932 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5934 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5936 sv_catpvs(msg, ": none");
5937 sv_catpvs(msg, " vs ");
5939 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5941 sv_catpvs(msg, "none");
5942 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5946 static void const_sv_xsub(pTHX_ CV* cv);
5950 =head1 Optree Manipulation Functions
5952 =for apidoc cv_const_sv
5954 If C<cv> is a constant sub eligible for inlining. returns the constant
5955 value returned by the sub. Otherwise, returns NULL.
5957 Constant subs can be created with C<newCONSTSUB> or as described in
5958 L<perlsub/"Constant Functions">.
5963 Perl_cv_const_sv(pTHX_ const CV *const cv)
5965 PERL_UNUSED_CONTEXT;
5968 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5970 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5973 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5974 * Can be called in 3 ways:
5977 * look for a single OP_CONST with attached value: return the value
5979 * cv && CvCLONE(cv) && !CvCONST(cv)
5981 * examine the clone prototype, and if contains only a single
5982 * OP_CONST referencing a pad const, or a single PADSV referencing
5983 * an outer lexical, return a non-zero value to indicate the CV is
5984 * a candidate for "constizing" at clone time
5988 * We have just cloned an anon prototype that was marked as a const
5989 * candidiate. Try to grab the current value, and in the case of
5990 * PADSV, ignore it if it has multiple references. Return the value.
5994 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6005 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6006 o = cLISTOPo->op_first->op_sibling;
6008 for (; o; o = o->op_next) {
6009 const OPCODE type = o->op_type;
6011 if (sv && o->op_next == o)
6013 if (o->op_next != o) {
6014 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6016 if (type == OP_DBSTATE)
6019 if (type == OP_LEAVESUB || type == OP_RETURN)
6023 if (type == OP_CONST && cSVOPo->op_sv)
6025 else if (cv && type == OP_CONST) {
6026 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6030 else if (cv && type == OP_PADSV) {
6031 if (CvCONST(cv)) { /* newly cloned anon */
6032 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6033 /* the candidate should have 1 ref from this pad and 1 ref
6034 * from the parent */
6035 if (!sv || SvREFCNT(sv) != 2)
6042 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6043 sv = &PL_sv_undef; /* an arbitrary non-null value */
6058 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6061 /* This would be the return value, but the return cannot be reached. */
6062 OP* pegop = newOP(OP_NULL, 0);
6065 PERL_UNUSED_ARG(floor);
6075 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6077 NORETURN_FUNCTION_END;
6082 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6087 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6088 register CV *cv = NULL;
6090 /* If the subroutine has no body, no attributes, and no builtin attributes
6091 then it's just a sub declaration, and we may be able to get away with
6092 storing with a placeholder scalar in the symbol table, rather than a
6093 full GV and CV. If anything is present then it will take a full CV to
6095 const I32 gv_fetch_flags
6096 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6098 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6099 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6103 assert(proto->op_type == OP_CONST);
6104 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6110 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6112 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6113 SV * const sv = sv_newmortal();
6114 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6115 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6116 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6117 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6119 } else if (PL_curstash) {
6120 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6123 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6127 if (!PL_madskills) {
6136 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6137 maximum a prototype before. */
6138 if (SvTYPE(gv) > SVt_NULL) {
6139 if (!SvPOK((const SV *)gv)
6140 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6142 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6144 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6147 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6149 sv_setiv(MUTABLE_SV(gv), -1);
6151 SvREFCNT_dec(PL_compcv);
6152 cv = PL_compcv = NULL;
6156 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6158 if (!block || !ps || *ps || attrs
6159 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6161 || block->op_type == OP_NULL
6166 const_sv = op_const_sv(block, NULL);
6169 const bool exists = CvROOT(cv) || CvXSUB(cv);
6171 /* if the subroutine doesn't exist and wasn't pre-declared
6172 * with a prototype, assume it will be AUTOLOADed,
6173 * skipping the prototype check
6175 if (exists || SvPOK(cv))
6176 cv_ckproto_len(cv, gv, ps, ps_len);
6177 /* already defined (or promised)? */
6178 if (exists || GvASSUMECV(gv)) {
6181 || block->op_type == OP_NULL
6184 if (CvFLAGS(PL_compcv)) {
6185 /* might have had built-in attrs applied */
6186 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6187 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6188 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6190 /* just a "sub foo;" when &foo is already defined */
6191 SAVEFREESV(PL_compcv);
6196 && block->op_type != OP_NULL
6199 if (ckWARN(WARN_REDEFINE)
6201 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6203 const line_t oldline = CopLINE(PL_curcop);
6204 if (PL_parser && PL_parser->copline != NOLINE)
6205 CopLINE_set(PL_curcop, PL_parser->copline);
6206 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6207 CvCONST(cv) ? "Constant subroutine %s redefined"
6208 : "Subroutine %s redefined", name);
6209 CopLINE_set(PL_curcop, oldline);
6212 if (!PL_minus_c) /* keep old one around for madskills */
6215 /* (PL_madskills unset in used file.) */
6223 SvREFCNT_inc_simple_void_NN(const_sv);
6225 assert(!CvROOT(cv) && !CvCONST(cv));
6226 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6227 CvXSUBANY(cv).any_ptr = const_sv;
6228 CvXSUB(cv) = const_sv_xsub;
6234 cv = newCONSTSUB(NULL, name, const_sv);
6236 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6237 (CvGV(cv) && GvSTASH(CvGV(cv)))
6246 SvREFCNT_dec(PL_compcv);
6250 if (cv) { /* must reuse cv if autoloaded */
6251 /* transfer PL_compcv to cv */
6254 && block->op_type != OP_NULL
6257 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6258 AV *const temp_av = CvPADLIST(cv);
6259 CV *const temp_cv = CvOUTSIDE(cv);
6261 assert(!CvWEAKOUTSIDE(cv));
6262 assert(!CvCVGV_RC(cv));
6263 assert(CvGV(cv) == gv);
6266 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6267 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6268 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6269 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6270 CvOUTSIDE(PL_compcv) = temp_cv;
6271 CvPADLIST(PL_compcv) = temp_av;
6274 if (CvFILE(cv) && !CvISXSUB(cv)) {
6275 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6276 Safefree(CvFILE(cv));
6279 CvFILE_set_from_cop(cv, PL_curcop);
6280 CvSTASH_set(cv, PL_curstash);
6282 /* inner references to PL_compcv must be fixed up ... */
6283 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6284 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6285 ++PL_sub_generation;
6288 /* Might have had built-in attributes applied -- propagate them. */
6289 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6291 /* ... before we throw it away */
6292 SvREFCNT_dec(PL_compcv);
6300 if (strEQ(name, "import")) {
6301 PL_formfeed = MUTABLE_SV(cv);
6302 /* diag_listed_as: SKIPME */
6303 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6307 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6312 CvFILE_set_from_cop(cv, PL_curcop);
6313 CvSTASH_set(cv, PL_curstash);
6316 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6317 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6318 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6322 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6324 if (PL_parser && PL_parser->error_count) {
6328 const char *s = strrchr(name, ':');
6330 if (strEQ(s, "BEGIN")) {
6331 const char not_safe[] =
6332 "BEGIN not safe after errors--compilation aborted";
6333 if (PL_in_eval & EVAL_KEEPERR)
6334 Perl_croak(aTHX_ not_safe);
6336 /* force display of errors found but not reported */
6337 sv_catpv(ERRSV, not_safe);
6338 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6347 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6348 the debugger could be able to set a breakpoint in, so signal to
6349 pp_entereval that it should not throw away any saved lines at scope
6352 PL_breakable_sub_gen++;
6354 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6355 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6356 block->op_attached = 1;
6359 /* This makes sub {}; work as expected. */
6360 if (block->op_type == OP_STUB) {
6361 OP* const newblock = newSTATEOP(0, NULL, 0);
6363 op_getmad(block,newblock,'B');
6370 block->op_attached = 1;
6371 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6373 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6374 OpREFCNT_set(CvROOT(cv), 1);
6375 CvSTART(cv) = LINKLIST(CvROOT(cv));
6376 CvROOT(cv)->op_next = 0;
6377 CALL_PEEP(CvSTART(cv));
6379 /* now that optimizer has done its work, adjust pad values */
6381 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6384 assert(!CvCONST(cv));
6385 if (ps && !*ps && op_const_sv(block, cv))
6390 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6391 SV * const tmpstr = sv_newmortal();
6392 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6393 GV_ADDMULTI, SVt_PVHV);
6395 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6398 (long)CopLINE(PL_curcop));
6399 gv_efullname3(tmpstr, gv, NULL);
6400 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6401 SvCUR(tmpstr), sv, 0);
6402 hv = GvHVn(db_postponed);
6403 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6404 CV * const pcv = GvCV(db_postponed);
6410 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6415 if (name && ! (PL_parser && PL_parser->error_count))
6416 process_special_blocks(name, gv, cv);
6421 PL_parser->copline = NOLINE;
6427 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6430 const char *const colon = strrchr(fullname,':');
6431 const char *const name = colon ? colon + 1 : fullname;
6433 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6436 if (strEQ(name, "BEGIN")) {
6437 const I32 oldscope = PL_scopestack_ix;
6439 SAVECOPFILE(&PL_compiling);
6440 SAVECOPLINE(&PL_compiling);
6442 DEBUG_x( dump_sub(gv) );
6443 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6444 GvCV(gv) = 0; /* cv has been hijacked */
6445 call_list(oldscope, PL_beginav);
6447 PL_curcop = &PL_compiling;
6448 CopHINTS_set(&PL_compiling, PL_hints);
6455 if strEQ(name, "END") {
6456 DEBUG_x( dump_sub(gv) );
6457 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6460 } else if (*name == 'U') {
6461 if (strEQ(name, "UNITCHECK")) {
6462 /* It's never too late to run a unitcheck block */
6463 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6467 } else if (*name == 'C') {
6468 if (strEQ(name, "CHECK")) {
6470 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6471 "Too late to run CHECK block");
6472 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6476 } else if (*name == 'I') {
6477 if (strEQ(name, "INIT")) {
6479 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6480 "Too late to run INIT block");
6481 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6487 DEBUG_x( dump_sub(gv) );
6488 GvCV(gv) = 0; /* cv has been hijacked */
6493 =for apidoc newCONSTSUB
6495 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6496 eligible for inlining at compile-time.
6498 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6499 which won't be called if used as a destructor, but will suppress the overhead
6500 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6507 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6512 const char *const file = CopFILE(PL_curcop);
6514 SV *const temp_sv = CopFILESV(PL_curcop);
6515 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6520 if (IN_PERL_RUNTIME) {
6521 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6522 * an op shared between threads. Use a non-shared COP for our
6524 SAVEVPTR(PL_curcop);
6525 PL_curcop = &PL_compiling;
6527 SAVECOPLINE(PL_curcop);
6528 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6531 PL_hints &= ~HINT_BLOCK_SCOPE;
6534 SAVESPTR(PL_curstash);
6535 SAVECOPSTASH(PL_curcop);
6536 PL_curstash = stash;
6537 CopSTASH_set(PL_curcop,stash);
6540 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6541 and so doesn't get free()d. (It's expected to be from the C pre-
6542 processor __FILE__ directive). But we need a dynamically allocated one,
6543 and we need it to get freed. */
6544 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6545 XS_DYNAMIC_FILENAME);
6546 CvXSUBANY(cv).any_ptr = sv;
6551 CopSTASH_free(PL_curcop);
6559 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6560 const char *const filename, const char *const proto,
6563 CV *cv = newXS(name, subaddr, filename);
6565 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6567 if (flags & XS_DYNAMIC_FILENAME) {
6568 /* We need to "make arrangements" (ie cheat) to ensure that the
6569 filename lasts as long as the PVCV we just created, but also doesn't
6571 STRLEN filename_len = strlen(filename);
6572 STRLEN proto_and_file_len = filename_len;
6573 char *proto_and_file;
6577 proto_len = strlen(proto);
6578 proto_and_file_len += proto_len;
6580 Newx(proto_and_file, proto_and_file_len + 1, char);
6581 Copy(proto, proto_and_file, proto_len, char);
6582 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6585 proto_and_file = savepvn(filename, filename_len);
6588 /* This gets free()d. :-) */
6589 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6590 SV_HAS_TRAILING_NUL);
6592 /* This gives us the correct prototype, rather than one with the
6593 file name appended. */
6594 SvCUR_set(cv, proto_len);
6598 CvFILE(cv) = proto_and_file + proto_len;
6600 sv_setpv(MUTABLE_SV(cv), proto);
6606 =for apidoc U||newXS
6608 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6609 static storage, as it is used directly as CvFILE(), without a copy being made.
6615 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6618 GV * const gv = gv_fetchpv(name ? name :
6619 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6620 GV_ADDMULTI, SVt_PVCV);
6623 PERL_ARGS_ASSERT_NEWXS;
6626 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6628 if ((cv = (name ? GvCV(gv) : NULL))) {
6630 /* just a cached method */
6634 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6635 /* already defined (or promised) */
6636 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6637 if (ckWARN(WARN_REDEFINE)) {
6638 GV * const gvcv = CvGV(cv);
6640 HV * const stash = GvSTASH(gvcv);
6642 const char *redefined_name = HvNAME_get(stash);
6643 if ( strEQ(redefined_name,"autouse") ) {
6644 const line_t oldline = CopLINE(PL_curcop);
6645 if (PL_parser && PL_parser->copline != NOLINE)
6646 CopLINE_set(PL_curcop, PL_parser->copline);
6647 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6648 CvCONST(cv) ? "Constant subroutine %s redefined"
6649 : "Subroutine %s redefined"
6651 CopLINE_set(PL_curcop, oldline);
6661 if (cv) /* must reuse cv if autoloaded */
6664 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6668 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6674 (void)gv_fetchfile(filename);
6675 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6676 an external constant string */
6678 CvXSUB(cv) = subaddr;
6681 process_special_blocks(name, gv, cv);
6691 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6696 OP* pegop = newOP(OP_NULL, 0);
6700 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6701 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6704 if ((cv = GvFORM(gv))) {
6705 if (ckWARN(WARN_REDEFINE)) {
6706 const line_t oldline = CopLINE(PL_curcop);
6707 if (PL_parser && PL_parser->copline != NOLINE)
6708 CopLINE_set(PL_curcop, PL_parser->copline);
6710 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6711 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6713 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6714 "Format STDOUT redefined");
6716 CopLINE_set(PL_curcop, oldline);
6723 CvFILE_set_from_cop(cv, PL_curcop);
6726 pad_tidy(padtidy_FORMAT);
6727 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6728 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6729 OpREFCNT_set(CvROOT(cv), 1);
6730 CvSTART(cv) = LINKLIST(CvROOT(cv));
6731 CvROOT(cv)->op_next = 0;
6732 CALL_PEEP(CvSTART(cv));
6734 op_getmad(o,pegop,'n');
6735 op_getmad_weak(block, pegop, 'b');
6740 PL_parser->copline = NOLINE;
6748 Perl_newANONLIST(pTHX_ OP *o)
6750 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6754 Perl_newANONHASH(pTHX_ OP *o)
6756 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6760 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6762 return newANONATTRSUB(floor, proto, NULL, block);
6766 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6768 return newUNOP(OP_REFGEN, 0,
6769 newSVOP(OP_ANONCODE, 0,
6770 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6774 Perl_oopsAV(pTHX_ OP *o)
6778 PERL_ARGS_ASSERT_OOPSAV;
6780 switch (o->op_type) {
6782 o->op_type = OP_PADAV;
6783 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6784 return ref(o, OP_RV2AV);
6787 o->op_type = OP_RV2AV;
6788 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6793 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6800 Perl_oopsHV(pTHX_ OP *o)
6804 PERL_ARGS_ASSERT_OOPSHV;
6806 switch (o->op_type) {
6809 o->op_type = OP_PADHV;
6810 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6811 return ref(o, OP_RV2HV);
6815 o->op_type = OP_RV2HV;
6816 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6821 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6828 Perl_newAVREF(pTHX_ OP *o)
6832 PERL_ARGS_ASSERT_NEWAVREF;
6834 if (o->op_type == OP_PADANY) {
6835 o->op_type = OP_PADAV;
6836 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6839 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6840 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6841 "Using an array as a reference is deprecated");
6843 return newUNOP(OP_RV2AV, 0, scalar(o));
6847 Perl_newGVREF(pTHX_ I32 type, OP *o)
6849 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6850 return newUNOP(OP_NULL, 0, o);
6851 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6855 Perl_newHVREF(pTHX_ OP *o)
6859 PERL_ARGS_ASSERT_NEWHVREF;
6861 if (o->op_type == OP_PADANY) {
6862 o->op_type = OP_PADHV;
6863 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6866 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6867 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6868 "Using a hash as a reference is deprecated");
6870 return newUNOP(OP_RV2HV, 0, scalar(o));
6874 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6876 return newUNOP(OP_RV2CV, flags, scalar(o));
6880 Perl_newSVREF(pTHX_ OP *o)
6884 PERL_ARGS_ASSERT_NEWSVREF;
6886 if (o->op_type == OP_PADANY) {
6887 o->op_type = OP_PADSV;
6888 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6891 return newUNOP(OP_RV2SV, 0, scalar(o));
6894 /* Check routines. See the comments at the top of this file for details
6895 * on when these are called */
6898 Perl_ck_anoncode(pTHX_ OP *o)
6900 PERL_ARGS_ASSERT_CK_ANONCODE;
6902 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6904 cSVOPo->op_sv = NULL;
6909 Perl_ck_bitop(pTHX_ OP *o)
6913 PERL_ARGS_ASSERT_CK_BITOP;
6915 #define OP_IS_NUMCOMPARE(op) \
6916 ((op) == OP_LT || (op) == OP_I_LT || \
6917 (op) == OP_GT || (op) == OP_I_GT || \
6918 (op) == OP_LE || (op) == OP_I_LE || \
6919 (op) == OP_GE || (op) == OP_I_GE || \
6920 (op) == OP_EQ || (op) == OP_I_EQ || \
6921 (op) == OP_NE || (op) == OP_I_NE || \
6922 (op) == OP_NCMP || (op) == OP_I_NCMP)
6923 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6924 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6925 && (o->op_type == OP_BIT_OR
6926 || o->op_type == OP_BIT_AND
6927 || o->op_type == OP_BIT_XOR))
6929 const OP * const left = cBINOPo->op_first;
6930 const OP * const right = left->op_sibling;
6931 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6932 (left->op_flags & OPf_PARENS) == 0) ||
6933 (OP_IS_NUMCOMPARE(right->op_type) &&
6934 (right->op_flags & OPf_PARENS) == 0))
6935 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6936 "Possible precedence problem on bitwise %c operator",
6937 o->op_type == OP_BIT_OR ? '|'
6938 : o->op_type == OP_BIT_AND ? '&' : '^'
6945 Perl_ck_concat(pTHX_ OP *o)
6947 const OP * const kid = cUNOPo->op_first;
6949 PERL_ARGS_ASSERT_CK_CONCAT;
6950 PERL_UNUSED_CONTEXT;
6952 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6953 !(kUNOP->op_first->op_flags & OPf_MOD))
6954 o->op_flags |= OPf_STACKED;
6959 Perl_ck_spair(pTHX_ OP *o)
6963 PERL_ARGS_ASSERT_CK_SPAIR;
6965 if (o->op_flags & OPf_KIDS) {
6968 const OPCODE type = o->op_type;
6969 o = modkids(ck_fun(o), type);
6970 kid = cUNOPo->op_first;
6971 newop = kUNOP->op_first->op_sibling;
6973 const OPCODE type = newop->op_type;
6974 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6975 type == OP_PADAV || type == OP_PADHV ||
6976 type == OP_RV2AV || type == OP_RV2HV)
6980 op_getmad(kUNOP->op_first,newop,'K');
6982 op_free(kUNOP->op_first);
6984 kUNOP->op_first = newop;
6986 o->op_ppaddr = PL_ppaddr[++o->op_type];
6991 Perl_ck_delete(pTHX_ OP *o)
6993 PERL_ARGS_ASSERT_CK_DELETE;
6997 if (o->op_flags & OPf_KIDS) {
6998 OP * const kid = cUNOPo->op_first;
6999 switch (kid->op_type) {
7001 o->op_flags |= OPf_SPECIAL;
7004 o->op_private |= OPpSLICE;
7007 o->op_flags |= OPf_SPECIAL;
7012 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7015 if (kid->op_private & OPpLVAL_INTRO)
7016 o->op_private |= OPpLVAL_INTRO;
7023 Perl_ck_die(pTHX_ OP *o)
7025 PERL_ARGS_ASSERT_CK_DIE;
7028 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7034 Perl_ck_eof(pTHX_ OP *o)
7038 PERL_ARGS_ASSERT_CK_EOF;
7040 if (o->op_flags & OPf_KIDS) {
7041 if (cLISTOPo->op_first->op_type == OP_STUB) {
7043 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7045 op_getmad(o,newop,'O');
7057 Perl_ck_eval(pTHX_ OP *o)
7061 PERL_ARGS_ASSERT_CK_EVAL;
7063 PL_hints |= HINT_BLOCK_SCOPE;
7064 if (o->op_flags & OPf_KIDS) {
7065 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7068 o->op_flags &= ~OPf_KIDS;
7071 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7077 cUNOPo->op_first = 0;
7082 NewOp(1101, enter, 1, LOGOP);
7083 enter->op_type = OP_ENTERTRY;
7084 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7085 enter->op_private = 0;
7087 /* establish postfix order */
7088 enter->op_next = (OP*)enter;
7090 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7091 o->op_type = OP_LEAVETRY;
7092 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7093 enter->op_other = o;
7094 op_getmad(oldo,o,'O');
7108 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7109 op_getmad(oldo,o,'O');
7111 o->op_targ = (PADOFFSET)PL_hints;
7112 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7113 /* Store a copy of %^H that pp_entereval can pick up. */
7114 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7115 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7116 cUNOPo->op_first->op_sibling = hhop;
7117 o->op_private |= OPpEVAL_HAS_HH;
7123 Perl_ck_exit(pTHX_ OP *o)
7125 PERL_ARGS_ASSERT_CK_EXIT;
7128 HV * const table = GvHV(PL_hintgv);
7130 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7131 if (svp && *svp && SvTRUE(*svp))
7132 o->op_private |= OPpEXIT_VMSISH;
7134 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7140 Perl_ck_exec(pTHX_ OP *o)
7142 PERL_ARGS_ASSERT_CK_EXEC;
7144 if (o->op_flags & OPf_STACKED) {
7147 kid = cUNOPo->op_first->op_sibling;
7148 if (kid->op_type == OP_RV2GV)
7157 Perl_ck_exists(pTHX_ OP *o)
7161 PERL_ARGS_ASSERT_CK_EXISTS;
7164 if (o->op_flags & OPf_KIDS) {
7165 OP * const kid = cUNOPo->op_first;
7166 if (kid->op_type == OP_ENTERSUB) {
7167 (void) ref(kid, o->op_type);
7168 if (kid->op_type != OP_RV2CV
7169 && !(PL_parser && PL_parser->error_count))
7170 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7172 o->op_private |= OPpEXISTS_SUB;
7174 else if (kid->op_type == OP_AELEM)
7175 o->op_flags |= OPf_SPECIAL;
7176 else if (kid->op_type != OP_HELEM)
7177 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7185 Perl_ck_rvconst(pTHX_ register OP *o)
7188 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7190 PERL_ARGS_ASSERT_CK_RVCONST;
7192 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7193 if (o->op_type == OP_RV2CV)
7194 o->op_private &= ~1;
7196 if (kid->op_type == OP_CONST) {
7199 SV * const kidsv = kid->op_sv;
7201 /* Is it a constant from cv_const_sv()? */
7202 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7203 SV * const rsv = SvRV(kidsv);
7204 const svtype type = SvTYPE(rsv);
7205 const char *badtype = NULL;
7207 switch (o->op_type) {
7209 if (type > SVt_PVMG)
7210 badtype = "a SCALAR";
7213 if (type != SVt_PVAV)
7214 badtype = "an ARRAY";
7217 if (type != SVt_PVHV)
7221 if (type != SVt_PVCV)
7226 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7229 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7230 const char *badthing;
7231 switch (o->op_type) {
7233 badthing = "a SCALAR";
7236 badthing = "an ARRAY";
7239 badthing = "a HASH";
7247 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7248 SVfARG(kidsv), badthing);
7251 * This is a little tricky. We only want to add the symbol if we
7252 * didn't add it in the lexer. Otherwise we get duplicate strict
7253 * warnings. But if we didn't add it in the lexer, we must at
7254 * least pretend like we wanted to add it even if it existed before,
7255 * or we get possible typo warnings. OPpCONST_ENTERED says
7256 * whether the lexer already added THIS instance of this symbol.
7258 iscv = (o->op_type == OP_RV2CV) * 2;
7260 gv = gv_fetchsv(kidsv,
7261 iscv | !(kid->op_private & OPpCONST_ENTERED),
7264 : o->op_type == OP_RV2SV
7266 : o->op_type == OP_RV2AV
7268 : o->op_type == OP_RV2HV
7271 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7273 kid->op_type = OP_GV;
7274 SvREFCNT_dec(kid->op_sv);
7276 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7277 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7278 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7280 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7282 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7284 kid->op_private = 0;
7285 kid->op_ppaddr = PL_ppaddr[OP_GV];
7286 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7294 Perl_ck_ftst(pTHX_ OP *o)
7297 const I32 type = o->op_type;
7299 PERL_ARGS_ASSERT_CK_FTST;
7301 if (o->op_flags & OPf_REF) {
7304 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7305 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7306 const OPCODE kidtype = kid->op_type;
7308 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7309 OP * const newop = newGVOP(type, OPf_REF,
7310 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7312 op_getmad(o,newop,'O');
7318 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7319 o->op_private |= OPpFT_ACCESS;
7320 if (PL_check[kidtype] == Perl_ck_ftst
7321 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7322 o->op_private |= OPpFT_STACKED;
7330 if (type == OP_FTTTY)
7331 o = newGVOP(type, OPf_REF, PL_stdingv);
7333 o = newUNOP(type, 0, newDEFSVOP());
7334 op_getmad(oldo,o,'O');
7340 Perl_ck_fun(pTHX_ OP *o)
7343 const int type = o->op_type;
7344 register I32 oa = PL_opargs[type] >> OASHIFT;
7346 PERL_ARGS_ASSERT_CK_FUN;
7348 if (o->op_flags & OPf_STACKED) {
7349 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7352 return no_fh_allowed(o);
7355 if (o->op_flags & OPf_KIDS) {
7356 OP **tokid = &cLISTOPo->op_first;
7357 register OP *kid = cLISTOPo->op_first;
7361 if (kid->op_type == OP_PUSHMARK ||
7362 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7364 tokid = &kid->op_sibling;
7365 kid = kid->op_sibling;
7367 if (!kid && PL_opargs[type] & OA_DEFGV)
7368 *tokid = kid = newDEFSVOP();
7372 sibl = kid->op_sibling;
7374 if (!sibl && kid->op_type == OP_STUB) {
7381 /* list seen where single (scalar) arg expected? */
7382 if (numargs == 1 && !(oa >> 4)
7383 && kid->op_type == OP_LIST && type != OP_SCALAR)
7385 return too_many_arguments(o,PL_op_desc[type]);
7398 if ((type == OP_PUSH || type == OP_UNSHIFT)
7399 && !kid->op_sibling)
7400 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7401 "Useless use of %s with no values",
7404 if (kid->op_type == OP_CONST &&
7405 (kid->op_private & OPpCONST_BARE))
7407 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7408 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7409 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7410 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7411 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7413 op_getmad(kid,newop,'K');
7418 kid->op_sibling = sibl;
7421 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7422 bad_type(numargs, "array", PL_op_desc[type], kid);
7423 op_lvalue(kid, type);
7426 if (kid->op_type == OP_CONST &&
7427 (kid->op_private & OPpCONST_BARE))
7429 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7430 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7431 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7432 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7433 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7435 op_getmad(kid,newop,'K');
7440 kid->op_sibling = sibl;
7443 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7444 bad_type(numargs, "hash", PL_op_desc[type], kid);
7445 op_lvalue(kid, type);
7449 OP * const newop = newUNOP(OP_NULL, 0, kid);
7450 kid->op_sibling = 0;
7452 newop->op_next = newop;
7454 kid->op_sibling = sibl;
7459 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7460 if (kid->op_type == OP_CONST &&
7461 (kid->op_private & OPpCONST_BARE))
7463 OP * const newop = newGVOP(OP_GV, 0,
7464 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7465 if (!(o->op_private & 1) && /* if not unop */
7466 kid == cLISTOPo->op_last)
7467 cLISTOPo->op_last = newop;
7469 op_getmad(kid,newop,'K');
7475 else if (kid->op_type == OP_READLINE) {
7476 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7477 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7480 I32 flags = OPf_SPECIAL;
7484 /* is this op a FH constructor? */
7485 if (is_handle_constructor(o,numargs)) {
7486 const char *name = NULL;
7490 /* Set a flag to tell rv2gv to vivify
7491 * need to "prove" flag does not mean something
7492 * else already - NI-S 1999/05/07
7495 if (kid->op_type == OP_PADSV) {
7497 = PAD_COMPNAME_SV(kid->op_targ);
7498 name = SvPV_const(namesv, len);
7500 else if (kid->op_type == OP_RV2SV
7501 && kUNOP->op_first->op_type == OP_GV)
7503 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7505 len = GvNAMELEN(gv);
7507 else if (kid->op_type == OP_AELEM
7508 || kid->op_type == OP_HELEM)
7511 OP *op = ((BINOP*)kid)->op_first;
7515 const char * const a =
7516 kid->op_type == OP_AELEM ?
7518 if (((op->op_type == OP_RV2AV) ||
7519 (op->op_type == OP_RV2HV)) &&
7520 (firstop = ((UNOP*)op)->op_first) &&
7521 (firstop->op_type == OP_GV)) {
7522 /* packagevar $a[] or $h{} */
7523 GV * const gv = cGVOPx_gv(firstop);
7531 else if (op->op_type == OP_PADAV
7532 || op->op_type == OP_PADHV) {
7533 /* lexicalvar $a[] or $h{} */
7534 const char * const padname =
7535 PAD_COMPNAME_PV(op->op_targ);
7544 name = SvPV_const(tmpstr, len);
7549 name = "__ANONIO__";
7552 op_lvalue(kid, type);
7556 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7557 namesv = PAD_SVl(targ);
7558 SvUPGRADE(namesv, SVt_PV);
7560 sv_setpvs(namesv, "$");
7561 sv_catpvn(namesv, name, len);
7564 kid->op_sibling = 0;
7565 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7566 kid->op_targ = targ;
7567 kid->op_private |= priv;
7569 kid->op_sibling = sibl;
7575 op_lvalue(scalar(kid), type);
7579 tokid = &kid->op_sibling;
7580 kid = kid->op_sibling;
7583 if (kid && kid->op_type != OP_STUB)
7584 return too_many_arguments(o,OP_DESC(o));
7585 o->op_private |= numargs;
7587 /* FIXME - should the numargs move as for the PERL_MAD case? */
7588 o->op_private |= numargs;
7590 return too_many_arguments(o,OP_DESC(o));
7594 else if (PL_opargs[type] & OA_DEFGV) {
7596 OP *newop = newUNOP(type, 0, newDEFSVOP());
7597 op_getmad(o,newop,'O');
7600 /* Ordering of these two is important to keep f_map.t passing. */
7602 return newUNOP(type, 0, newDEFSVOP());
7607 while (oa & OA_OPTIONAL)
7609 if (oa && oa != OA_LIST)
7610 return too_few_arguments(o,OP_DESC(o));
7616 Perl_ck_glob(pTHX_ OP *o)
7621 PERL_ARGS_ASSERT_CK_GLOB;
7624 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7625 op_append_elem(OP_GLOB, o, newDEFSVOP());
7627 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7628 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7630 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7633 #if !defined(PERL_EXTERNAL_GLOB)
7634 /* XXX this can be tightened up and made more failsafe. */
7635 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7638 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7639 newSVpvs("File::Glob"), NULL, NULL, NULL);
7640 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7641 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7642 GvCV(gv) = GvCV(glob_gv);
7643 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7644 GvIMPORTED_CV_on(gv);
7648 #endif /* PERL_EXTERNAL_GLOB */
7650 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7651 op_append_elem(OP_GLOB, o,
7652 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7653 o->op_type = OP_LIST;
7654 o->op_ppaddr = PL_ppaddr[OP_LIST];
7655 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7656 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7657 cLISTOPo->op_first->op_targ = 0;
7658 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7659 op_append_elem(OP_LIST, o,
7660 scalar(newUNOP(OP_RV2CV, 0,
7661 newGVOP(OP_GV, 0, gv)))));
7662 o = newUNOP(OP_NULL, 0, ck_subr(o));
7663 o->op_targ = OP_GLOB; /* hint at what it used to be */
7666 gv = newGVgen("main");
7668 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7674 Perl_ck_grep(pTHX_ OP *o)
7679 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7682 PERL_ARGS_ASSERT_CK_GREP;
7684 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7685 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7687 if (o->op_flags & OPf_STACKED) {
7690 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7691 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7692 return no_fh_allowed(o);
7693 for (k = kid; k; k = k->op_next) {
7696 NewOp(1101, gwop, 1, LOGOP);
7697 kid->op_next = (OP*)gwop;
7698 o->op_flags &= ~OPf_STACKED;
7700 kid = cLISTOPo->op_first->op_sibling;
7701 if (type == OP_MAPWHILE)
7706 if (PL_parser && PL_parser->error_count)
7708 kid = cLISTOPo->op_first->op_sibling;
7709 if (kid->op_type != OP_NULL)
7710 Perl_croak(aTHX_ "panic: ck_grep");
7711 kid = kUNOP->op_first;
7714 NewOp(1101, gwop, 1, LOGOP);
7715 gwop->op_type = type;
7716 gwop->op_ppaddr = PL_ppaddr[type];
7717 gwop->op_first = listkids(o);
7718 gwop->op_flags |= OPf_KIDS;
7719 gwop->op_other = LINKLIST(kid);
7720 kid->op_next = (OP*)gwop;
7721 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7722 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7723 o->op_private = gwop->op_private = 0;
7724 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7727 o->op_private = gwop->op_private = OPpGREP_LEX;
7728 gwop->op_targ = o->op_targ = offset;
7731 kid = cLISTOPo->op_first->op_sibling;
7732 if (!kid || !kid->op_sibling)
7733 return too_few_arguments(o,OP_DESC(o));
7734 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7735 op_lvalue(kid, OP_GREPSTART);
7741 Perl_ck_index(pTHX_ OP *o)
7743 PERL_ARGS_ASSERT_CK_INDEX;
7745 if (o->op_flags & OPf_KIDS) {
7746 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7748 kid = kid->op_sibling; /* get past "big" */
7749 if (kid && kid->op_type == OP_CONST)
7750 fbm_compile(((SVOP*)kid)->op_sv, 0);
7756 Perl_ck_lfun(pTHX_ OP *o)
7758 const OPCODE type = o->op_type;
7760 PERL_ARGS_ASSERT_CK_LFUN;
7762 return modkids(ck_fun(o), type);
7766 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7768 PERL_ARGS_ASSERT_CK_DEFINED;
7770 if ((o->op_flags & OPf_KIDS)) {
7771 switch (cUNOPo->op_first->op_type) {
7773 /* This is needed for
7774 if (defined %stash::)
7775 to work. Do not break Tk.
7777 break; /* Globals via GV can be undef */
7779 case OP_AASSIGN: /* Is this a good idea? */
7780 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7781 "defined(@array) is deprecated");
7782 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7783 "\t(Maybe you should just omit the defined()?)\n");
7787 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7788 "defined(%%hash) is deprecated");
7789 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7790 "\t(Maybe you should just omit the defined()?)\n");
7801 Perl_ck_readline(pTHX_ OP *o)
7803 PERL_ARGS_ASSERT_CK_READLINE;
7805 if (!(o->op_flags & OPf_KIDS)) {
7807 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7809 op_getmad(o,newop,'O');
7819 Perl_ck_rfun(pTHX_ OP *o)
7821 const OPCODE type = o->op_type;
7823 PERL_ARGS_ASSERT_CK_RFUN;
7825 return refkids(ck_fun(o), type);
7829 Perl_ck_listiob(pTHX_ OP *o)
7833 PERL_ARGS_ASSERT_CK_LISTIOB;
7835 kid = cLISTOPo->op_first;
7838 kid = cLISTOPo->op_first;
7840 if (kid->op_type == OP_PUSHMARK)
7841 kid = kid->op_sibling;
7842 if (kid && o->op_flags & OPf_STACKED)
7843 kid = kid->op_sibling;
7844 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7845 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7846 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7847 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7848 cLISTOPo->op_first->op_sibling = kid;
7849 cLISTOPo->op_last = kid;
7850 kid = kid->op_sibling;
7855 op_append_elem(o->op_type, o, newDEFSVOP());
7861 Perl_ck_smartmatch(pTHX_ OP *o)
7864 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7865 if (0 == (o->op_flags & OPf_SPECIAL)) {
7866 OP *first = cBINOPo->op_first;
7867 OP *second = first->op_sibling;
7869 /* Implicitly take a reference to an array or hash */
7870 first->op_sibling = NULL;
7871 first = cBINOPo->op_first = ref_array_or_hash(first);
7872 second = first->op_sibling = ref_array_or_hash(second);
7874 /* Implicitly take a reference to a regular expression */
7875 if (first->op_type == OP_MATCH) {
7876 first->op_type = OP_QR;
7877 first->op_ppaddr = PL_ppaddr[OP_QR];
7879 if (second->op_type == OP_MATCH) {
7880 second->op_type = OP_QR;
7881 second->op_ppaddr = PL_ppaddr[OP_QR];
7890 Perl_ck_sassign(pTHX_ OP *o)
7893 OP * const kid = cLISTOPo->op_first;
7895 PERL_ARGS_ASSERT_CK_SASSIGN;
7897 /* has a disposable target? */
7898 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7899 && !(kid->op_flags & OPf_STACKED)
7900 /* Cannot steal the second time! */
7901 && !(kid->op_private & OPpTARGET_MY)
7902 /* Keep the full thing for madskills */
7906 OP * const kkid = kid->op_sibling;
7908 /* Can just relocate the target. */
7909 if (kkid && kkid->op_type == OP_PADSV
7910 && !(kkid->op_private & OPpLVAL_INTRO))
7912 kid->op_targ = kkid->op_targ;
7914 /* Now we do not need PADSV and SASSIGN. */
7915 kid->op_sibling = o->op_sibling; /* NULL */
7916 cLISTOPo->op_first = NULL;
7919 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7923 if (kid->op_sibling) {
7924 OP *kkid = kid->op_sibling;
7925 if (kkid->op_type == OP_PADSV
7926 && (kkid->op_private & OPpLVAL_INTRO)
7927 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7928 const PADOFFSET target = kkid->op_targ;
7929 OP *const other = newOP(OP_PADSV,
7931 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7932 OP *const first = newOP(OP_NULL, 0);
7933 OP *const nullop = newCONDOP(0, first, o, other);
7934 OP *const condop = first->op_next;
7935 /* hijacking PADSTALE for uninitialized state variables */
7936 SvPADSTALE_on(PAD_SVl(target));
7938 condop->op_type = OP_ONCE;
7939 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7940 condop->op_targ = target;
7941 other->op_targ = target;
7943 /* Because we change the type of the op here, we will skip the
7944 assinment binop->op_last = binop->op_first->op_sibling; at the
7945 end of Perl_newBINOP(). So need to do it here. */
7946 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7955 Perl_ck_match(pTHX_ OP *o)
7959 PERL_ARGS_ASSERT_CK_MATCH;
7961 if (o->op_type != OP_QR && PL_compcv) {
7962 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7963 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7964 o->op_targ = offset;
7965 o->op_private |= OPpTARGET_MY;
7968 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7969 o->op_private |= OPpRUNTIME;
7974 Perl_ck_method(pTHX_ OP *o)
7976 OP * const kid = cUNOPo->op_first;
7978 PERL_ARGS_ASSERT_CK_METHOD;
7980 if (kid->op_type == OP_CONST) {
7981 SV* sv = kSVOP->op_sv;
7982 const char * const method = SvPVX_const(sv);
7983 if (!(strchr(method, ':') || strchr(method, '\''))) {
7985 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7986 sv = newSVpvn_share(method, SvCUR(sv), 0);
7989 kSVOP->op_sv = NULL;
7991 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7993 op_getmad(o,cmop,'O');
8004 Perl_ck_null(pTHX_ OP *o)
8006 PERL_ARGS_ASSERT_CK_NULL;
8007 PERL_UNUSED_CONTEXT;
8012 Perl_ck_open(pTHX_ OP *o)
8015 HV * const table = GvHV(PL_hintgv);
8017 PERL_ARGS_ASSERT_CK_OPEN;
8020 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8023 const char *d = SvPV_const(*svp, len);
8024 const I32 mode = mode_from_discipline(d, len);
8025 if (mode & O_BINARY)
8026 o->op_private |= OPpOPEN_IN_RAW;
8027 else if (mode & O_TEXT)
8028 o->op_private |= OPpOPEN_IN_CRLF;
8031 svp = hv_fetchs(table, "open_OUT", FALSE);
8034 const char *d = SvPV_const(*svp, len);
8035 const I32 mode = mode_from_discipline(d, len);
8036 if (mode & O_BINARY)
8037 o->op_private |= OPpOPEN_OUT_RAW;
8038 else if (mode & O_TEXT)
8039 o->op_private |= OPpOPEN_OUT_CRLF;
8042 if (o->op_type == OP_BACKTICK) {
8043 if (!(o->op_flags & OPf_KIDS)) {
8044 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8046 op_getmad(o,newop,'O');
8055 /* In case of three-arg dup open remove strictness
8056 * from the last arg if it is a bareword. */
8057 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8058 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8062 if ((last->op_type == OP_CONST) && /* The bareword. */
8063 (last->op_private & OPpCONST_BARE) &&
8064 (last->op_private & OPpCONST_STRICT) &&
8065 (oa = first->op_sibling) && /* The fh. */
8066 (oa = oa->op_sibling) && /* The mode. */
8067 (oa->op_type == OP_CONST) &&
8068 SvPOK(((SVOP*)oa)->op_sv) &&
8069 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8070 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8071 (last == oa->op_sibling)) /* The bareword. */
8072 last->op_private &= ~OPpCONST_STRICT;
8078 Perl_ck_repeat(pTHX_ OP *o)
8080 PERL_ARGS_ASSERT_CK_REPEAT;
8082 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8083 o->op_private |= OPpREPEAT_DOLIST;
8084 cBINOPo->op_first = force_list(cBINOPo->op_first);
8092 Perl_ck_require(pTHX_ OP *o)
8097 PERL_ARGS_ASSERT_CK_REQUIRE;
8099 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8100 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8102 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8103 SV * const sv = kid->op_sv;
8104 U32 was_readonly = SvREADONLY(sv);
8111 sv_force_normal_flags(sv, 0);
8112 assert(!SvREADONLY(sv));
8122 for (; s < end; s++) {
8123 if (*s == ':' && s[1] == ':') {
8125 Move(s+2, s+1, end - s - 1, char);
8130 sv_catpvs(sv, ".pm");
8131 SvFLAGS(sv) |= was_readonly;
8135 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8136 /* handle override, if any */
8137 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8138 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8139 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8140 gv = gvp ? *gvp : NULL;
8144 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8145 OP * const kid = cUNOPo->op_first;
8148 cUNOPo->op_first = 0;
8152 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8153 op_append_elem(OP_LIST, kid,
8154 scalar(newUNOP(OP_RV2CV, 0,
8157 op_getmad(o,newop,'O');
8161 return scalar(ck_fun(o));
8165 Perl_ck_return(pTHX_ OP *o)
8170 PERL_ARGS_ASSERT_CK_RETURN;
8172 kid = cLISTOPo->op_first->op_sibling;
8173 if (CvLVALUE(PL_compcv)) {
8174 for (; kid; kid = kid->op_sibling)
8175 op_lvalue(kid, OP_LEAVESUBLV);
8177 for (; kid; kid = kid->op_sibling)
8178 if ((kid->op_type == OP_NULL)
8179 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8180 /* This is a do block */
8181 OP *op = kUNOP->op_first;
8182 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8183 op = cUNOPx(op)->op_first;
8184 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8185 /* Force the use of the caller's context */
8186 op->op_flags |= OPf_SPECIAL;
8195 Perl_ck_select(pTHX_ OP *o)
8200 PERL_ARGS_ASSERT_CK_SELECT;
8202 if (o->op_flags & OPf_KIDS) {
8203 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8204 if (kid && kid->op_sibling) {
8205 o->op_type = OP_SSELECT;
8206 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8208 return fold_constants(o);
8212 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8213 if (kid && kid->op_type == OP_RV2GV)
8214 kid->op_private &= ~HINT_STRICT_REFS;
8219 Perl_ck_shift(pTHX_ OP *o)
8222 const I32 type = o->op_type;
8224 PERL_ARGS_ASSERT_CK_SHIFT;
8226 if (!(o->op_flags & OPf_KIDS)) {
8229 if (!CvUNIQUE(PL_compcv)) {
8230 o->op_flags |= OPf_SPECIAL;
8234 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8237 OP * const oldo = o;
8238 o = newUNOP(type, 0, scalar(argop));
8239 op_getmad(oldo,o,'O');
8244 return newUNOP(type, 0, scalar(argop));
8247 return scalar(modkids(ck_push(o), type));
8251 Perl_ck_sort(pTHX_ OP *o)
8256 PERL_ARGS_ASSERT_CK_SORT;
8258 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8259 HV * const hinthv = GvHV(PL_hintgv);
8261 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8263 const I32 sorthints = (I32)SvIV(*svp);
8264 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8265 o->op_private |= OPpSORT_QSORT;
8266 if ((sorthints & HINT_SORT_STABLE) != 0)
8267 o->op_private |= OPpSORT_STABLE;
8272 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8274 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8275 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8277 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8279 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8281 if (kid->op_type == OP_SCOPE) {
8285 else if (kid->op_type == OP_LEAVE) {
8286 if (o->op_type == OP_SORT) {
8287 op_null(kid); /* wipe out leave */
8290 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8291 if (k->op_next == kid)
8293 /* don't descend into loops */
8294 else if (k->op_type == OP_ENTERLOOP
8295 || k->op_type == OP_ENTERITER)
8297 k = cLOOPx(k)->op_lastop;
8302 kid->op_next = 0; /* just disconnect the leave */
8303 k = kLISTOP->op_first;
8308 if (o->op_type == OP_SORT) {
8309 /* provide scalar context for comparison function/block */
8315 o->op_flags |= OPf_SPECIAL;
8317 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8320 firstkid = firstkid->op_sibling;
8323 /* provide list context for arguments */
8324 if (o->op_type == OP_SORT)
8331 S_simplify_sort(pTHX_ OP *o)
8334 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8340 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8342 if (!(o->op_flags & OPf_STACKED))
8344 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8345 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8346 kid = kUNOP->op_first; /* get past null */
8347 if (kid->op_type != OP_SCOPE)
8349 kid = kLISTOP->op_last; /* get past scope */
8350 switch(kid->op_type) {
8358 k = kid; /* remember this node*/
8359 if (kBINOP->op_first->op_type != OP_RV2SV)
8361 kid = kBINOP->op_first; /* get past cmp */
8362 if (kUNOP->op_first->op_type != OP_GV)
8364 kid = kUNOP->op_first; /* get past rv2sv */
8366 if (GvSTASH(gv) != PL_curstash)
8368 gvname = GvNAME(gv);
8369 if (*gvname == 'a' && gvname[1] == '\0')
8371 else if (*gvname == 'b' && gvname[1] == '\0')
8376 kid = k; /* back to cmp */
8377 if (kBINOP->op_last->op_type != OP_RV2SV)
8379 kid = kBINOP->op_last; /* down to 2nd arg */
8380 if (kUNOP->op_first->op_type != OP_GV)
8382 kid = kUNOP->op_first; /* get past rv2sv */
8384 if (GvSTASH(gv) != PL_curstash)
8386 gvname = GvNAME(gv);
8388 ? !(*gvname == 'a' && gvname[1] == '\0')
8389 : !(*gvname == 'b' && gvname[1] == '\0'))
8391 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8393 o->op_private |= OPpSORT_DESCEND;
8394 if (k->op_type == OP_NCMP)
8395 o->op_private |= OPpSORT_NUMERIC;
8396 if (k->op_type == OP_I_NCMP)
8397 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8398 kid = cLISTOPo->op_first->op_sibling;
8399 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8401 op_getmad(kid,o,'S'); /* then delete it */
8403 op_free(kid); /* then delete it */
8408 Perl_ck_split(pTHX_ OP *o)
8413 PERL_ARGS_ASSERT_CK_SPLIT;
8415 if (o->op_flags & OPf_STACKED)
8416 return no_fh_allowed(o);
8418 kid = cLISTOPo->op_first;
8419 if (kid->op_type != OP_NULL)
8420 Perl_croak(aTHX_ "panic: ck_split");
8421 kid = kid->op_sibling;
8422 op_free(cLISTOPo->op_first);
8423 cLISTOPo->op_first = kid;
8425 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8426 cLISTOPo->op_last = kid; /* There was only one element previously */
8429 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8430 OP * const sibl = kid->op_sibling;
8431 kid->op_sibling = 0;
8432 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8433 if (cLISTOPo->op_first == cLISTOPo->op_last)
8434 cLISTOPo->op_last = kid;
8435 cLISTOPo->op_first = kid;
8436 kid->op_sibling = sibl;
8439 kid->op_type = OP_PUSHRE;
8440 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8442 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8443 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8444 "Use of /g modifier is meaningless in split");
8447 if (!kid->op_sibling)
8448 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8450 kid = kid->op_sibling;
8453 if (!kid->op_sibling)
8454 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8455 assert(kid->op_sibling);
8457 kid = kid->op_sibling;
8460 if (kid->op_sibling)
8461 return too_many_arguments(o,OP_DESC(o));
8467 Perl_ck_join(pTHX_ OP *o)
8469 const OP * const kid = cLISTOPo->op_first->op_sibling;
8471 PERL_ARGS_ASSERT_CK_JOIN;
8473 if (kid && kid->op_type == OP_MATCH) {
8474 if (ckWARN(WARN_SYNTAX)) {
8475 const REGEXP *re = PM_GETRE(kPMOP);
8476 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8477 const STRLEN len = re ? RX_PRELEN(re) : 6;
8478 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8479 "/%.*s/ should probably be written as \"%.*s\"",
8480 (int)len, pmstr, (int)len, pmstr);
8487 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8489 Examines an op, which is expected to identify a subroutine at runtime,
8490 and attempts to determine at compile time which subroutine it identifies.
8491 This is normally used during Perl compilation to determine whether
8492 a prototype can be applied to a function call. I<cvop> is the op
8493 being considered, normally an C<rv2cv> op. A pointer to the identified
8494 subroutine is returned, if it could be determined statically, and a null
8495 pointer is returned if it was not possible to determine statically.
8497 Currently, the subroutine can be identified statically if the RV that the
8498 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8499 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8500 suitable if the constant value must be an RV pointing to a CV. Details of
8501 this process may change in future versions of Perl. If the C<rv2cv> op
8502 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8503 the subroutine statically: this flag is used to suppress compile-time
8504 magic on a subroutine call, forcing it to use default runtime behaviour.
8506 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8507 of a GV reference is modified. If a GV was examined and its CV slot was
8508 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8509 If the op is not optimised away, and the CV slot is later populated with
8510 a subroutine having a prototype, that flag eventually triggers the warning
8511 "called too early to check prototype".
8513 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8514 of returning a pointer to the subroutine it returns a pointer to the
8515 GV giving the most appropriate name for the subroutine in this context.
8516 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8517 (C<CvANON>) subroutine that is referenced through a GV it will be the
8518 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8519 A null pointer is returned as usual if there is no statically-determinable
8526 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8531 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8532 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8533 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8534 if (cvop->op_type != OP_RV2CV)
8536 if (cvop->op_private & OPpENTERSUB_AMPER)
8538 if (!(cvop->op_flags & OPf_KIDS))
8540 rvop = cUNOPx(cvop)->op_first;
8541 switch (rvop->op_type) {
8543 gv = cGVOPx_gv(rvop);
8546 if (flags & RV2CVOPCV_MARK_EARLY)
8547 rvop->op_private |= OPpEARLY_CV;
8552 SV *rv = cSVOPx_sv(rvop);
8562 if (SvTYPE((SV*)cv) != SVt_PVCV)
8564 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8565 if (!CvANON(cv) || !gv)
8574 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8576 Performs the default fixup of the arguments part of an C<entersub>
8577 op tree. This consists of applying list context to each of the
8578 argument ops. This is the standard treatment used on a call marked
8579 with C<&>, or a method call, or a call through a subroutine reference,
8580 or any other call where the callee can't be identified at compile time,
8581 or a call where the callee has no prototype.
8587 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8590 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8591 aop = cUNOPx(entersubop)->op_first;
8592 if (!aop->op_sibling)
8593 aop = cUNOPx(aop)->op_first;
8594 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8595 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8597 op_lvalue(aop, OP_ENTERSUB);
8604 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8606 Performs the fixup of the arguments part of an C<entersub> op tree
8607 based on a subroutine prototype. This makes various modifications to
8608 the argument ops, from applying context up to inserting C<refgen> ops,
8609 and checking the number and syntactic types of arguments, as directed by
8610 the prototype. This is the standard treatment used on a subroutine call,
8611 not marked with C<&>, where the callee can be identified at compile time
8612 and has a prototype.
8614 I<protosv> supplies the subroutine prototype to be applied to the call.
8615 It may be a normal defined scalar, of which the string value will be used.
8616 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8617 that has been cast to C<SV*>) which has a prototype. The prototype
8618 supplied, in whichever form, does not need to match the actual callee
8619 referenced by the op tree.
8621 If the argument ops disagree with the prototype, for example by having
8622 an unacceptable number of arguments, a valid op tree is returned anyway.
8623 The error is reflected in the parser state, normally resulting in a single
8624 exception at the top level of parsing which covers all the compilation
8625 errors that occurred. In the error message, the callee is referred to
8626 by the name defined by the I<namegv> parameter.
8632 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8635 const char *proto, *proto_end;
8636 OP *aop, *prev, *cvop;
8639 I32 contextclass = 0;
8640 const char *e = NULL;
8641 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8642 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8643 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8644 proto = SvPV(protosv, proto_len);
8645 proto_end = proto + proto_len;
8646 aop = cUNOPx(entersubop)->op_first;
8647 if (!aop->op_sibling)
8648 aop = cUNOPx(aop)->op_first;
8650 aop = aop->op_sibling;
8651 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8652 while (aop != cvop) {
8654 if (PL_madskills && aop->op_type == OP_STUB) {
8655 aop = aop->op_sibling;
8658 if (PL_madskills && aop->op_type == OP_NULL)
8659 o3 = ((UNOP*)aop)->op_first;
8663 if (proto >= proto_end)
8664 return too_many_arguments(entersubop, gv_ename(namegv));
8672 /* _ must be at the end */
8673 if (proto[1] && proto[1] != ';')
8688 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8690 arg == 1 ? "block or sub {}" : "sub {}",
8691 gv_ename(namegv), o3);
8694 /* '*' allows any scalar type, including bareword */
8697 if (o3->op_type == OP_RV2GV)
8698 goto wrapref; /* autoconvert GLOB -> GLOBref */
8699 else if (o3->op_type == OP_CONST)
8700 o3->op_private &= ~OPpCONST_STRICT;
8701 else if (o3->op_type == OP_ENTERSUB) {
8702 /* accidental subroutine, revert to bareword */
8703 OP *gvop = ((UNOP*)o3)->op_first;
8704 if (gvop && gvop->op_type == OP_NULL) {
8705 gvop = ((UNOP*)gvop)->op_first;
8707 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8710 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8711 (gvop = ((UNOP*)gvop)->op_first) &&
8712 gvop->op_type == OP_GV)
8714 GV * const gv = cGVOPx_gv(gvop);
8715 OP * const sibling = aop->op_sibling;
8716 SV * const n = newSVpvs("");
8718 OP * const oldaop = aop;
8722 gv_fullname4(n, gv, "", FALSE);
8723 aop = newSVOP(OP_CONST, 0, n);
8724 op_getmad(oldaop,aop,'O');
8725 prev->op_sibling = aop;
8726 aop->op_sibling = sibling;
8736 if (o3->op_type == OP_RV2AV ||
8737 o3->op_type == OP_PADAV ||
8738 o3->op_type == OP_RV2HV ||
8739 o3->op_type == OP_PADHV
8754 if (contextclass++ == 0) {
8755 e = strchr(proto, ']');
8756 if (!e || e == proto)
8765 const char *p = proto;
8766 const char *const end = proto;
8768 while (*--p != '[') {}
8769 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8771 gv_ename(namegv), o3);
8776 if (o3->op_type == OP_RV2GV)
8779 bad_type(arg, "symbol", gv_ename(namegv), o3);
8782 if (o3->op_type == OP_ENTERSUB)
8785 bad_type(arg, "subroutine entry", gv_ename(namegv),
8789 if (o3->op_type == OP_RV2SV ||
8790 o3->op_type == OP_PADSV ||
8791 o3->op_type == OP_HELEM ||
8792 o3->op_type == OP_AELEM)
8795 bad_type(arg, "scalar", gv_ename(namegv), o3);
8798 if (o3->op_type == OP_RV2AV ||
8799 o3->op_type == OP_PADAV)
8802 bad_type(arg, "array", gv_ename(namegv), o3);
8805 if (o3->op_type == OP_RV2HV ||
8806 o3->op_type == OP_PADHV)
8809 bad_type(arg, "hash", gv_ename(namegv), o3);
8813 OP* const kid = aop;
8814 OP* const sib = kid->op_sibling;
8815 kid->op_sibling = 0;
8816 aop = newUNOP(OP_REFGEN, 0, kid);
8817 aop->op_sibling = sib;
8818 prev->op_sibling = aop;
8820 if (contextclass && e) {
8835 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8836 gv_ename(namegv), SVfARG(protosv));
8839 op_lvalue(aop, OP_ENTERSUB);
8841 aop = aop->op_sibling;
8843 if (aop == cvop && *proto == '_') {
8844 /* generate an access to $_ */
8846 aop->op_sibling = prev->op_sibling;
8847 prev->op_sibling = aop; /* instead of cvop */
8849 if (!optional && proto_end > proto &&
8850 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8851 return too_few_arguments(entersubop, gv_ename(namegv));
8856 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8858 Performs the fixup of the arguments part of an C<entersub> op tree either
8859 based on a subroutine prototype or using default list-context processing.
8860 This is the standard treatment used on a subroutine call, not marked
8861 with C<&>, where the callee can be identified at compile time.
8863 I<protosv> supplies the subroutine prototype to be applied to the call,
8864 or indicates that there is no prototype. It may be a normal scalar,
8865 in which case if it is defined then the string value will be used
8866 as a prototype, and if it is undefined then there is no prototype.
8867 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8868 that has been cast to C<SV*>), of which the prototype will be used if it
8869 has one. The prototype (or lack thereof) supplied, in whichever form,
8870 does not need to match the actual callee referenced by the op tree.
8872 If the argument ops disagree with the prototype, for example by having
8873 an unacceptable number of arguments, a valid op tree is returned anyway.
8874 The error is reflected in the parser state, normally resulting in a single
8875 exception at the top level of parsing which covers all the compilation
8876 errors that occurred. In the error message, the callee is referred to
8877 by the name defined by the I<namegv> parameter.
8883 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8884 GV *namegv, SV *protosv)
8886 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8887 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8888 return ck_entersub_args_proto(entersubop, namegv, protosv);
8890 return ck_entersub_args_list(entersubop);
8894 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8896 Retrieves the function that will be used to fix up a call to I<cv>.
8897 Specifically, the function is applied to an C<entersub> op tree for a
8898 subroutine call, not marked with C<&>, where the callee can be identified
8899 at compile time as I<cv>.
8901 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8902 argument for it is returned in I<*ckobj_p>. The function is intended
8903 to be called in this manner:
8905 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8907 In this call, I<entersubop> is a pointer to the C<entersub> op,
8908 which may be replaced by the check function, and I<namegv> is a GV
8909 supplying the name that should be used by the check function to refer
8910 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8911 It is permitted to apply the check function in non-standard situations,
8912 such as to a call to a different subroutine or to a method call.
8914 By default, the function is
8915 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8916 and the SV parameter is I<cv> itself. This implements standard
8917 prototype processing. It can be changed, for a particular subroutine,
8918 by L</cv_set_call_checker>.
8924 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8927 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8928 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8930 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8931 *ckobj_p = callmg->mg_obj;
8933 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8939 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8941 Sets the function that will be used to fix up a call to I<cv>.
8942 Specifically, the function is applied to an C<entersub> op tree for a
8943 subroutine call, not marked with C<&>, where the callee can be identified
8944 at compile time as I<cv>.
8946 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8947 for it is supplied in I<ckobj>. The function is intended to be called
8950 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8952 In this call, I<entersubop> is a pointer to the C<entersub> op,
8953 which may be replaced by the check function, and I<namegv> is a GV
8954 supplying the name that should be used by the check function to refer
8955 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8956 It is permitted to apply the check function in non-standard situations,
8957 such as to a call to a different subroutine or to a method call.
8959 The current setting for a particular CV can be retrieved by
8960 L</cv_get_call_checker>.
8966 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8968 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8969 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8970 if (SvMAGICAL((SV*)cv))
8971 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8974 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8975 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8976 if (callmg->mg_flags & MGf_REFCOUNTED) {
8977 SvREFCNT_dec(callmg->mg_obj);
8978 callmg->mg_flags &= ~MGf_REFCOUNTED;
8980 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8981 callmg->mg_obj = ckobj;
8982 if (ckobj != (SV*)cv) {
8983 SvREFCNT_inc_simple_void_NN(ckobj);
8984 callmg->mg_flags |= MGf_REFCOUNTED;
8990 Perl_ck_subr(pTHX_ OP *o)
8996 PERL_ARGS_ASSERT_CK_SUBR;
8998 aop = cUNOPx(o)->op_first;
8999 if (!aop->op_sibling)
9000 aop = cUNOPx(aop)->op_first;
9001 aop = aop->op_sibling;
9002 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9003 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9004 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9006 o->op_private |= OPpENTERSUB_HASTARG;
9007 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9008 if (PERLDB_SUB && PL_curstash != PL_debstash)
9009 o->op_private |= OPpENTERSUB_DB;
9010 if (cvop->op_type == OP_RV2CV) {
9011 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9013 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9014 if (aop->op_type == OP_CONST)
9015 aop->op_private &= ~OPpCONST_STRICT;
9016 else if (aop->op_type == OP_LIST) {
9017 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9018 if (sib && sib->op_type == OP_CONST)
9019 sib->op_private &= ~OPpCONST_STRICT;
9024 return ck_entersub_args_list(o);
9026 Perl_call_checker ckfun;
9028 cv_get_call_checker(cv, &ckfun, &ckobj);
9029 return ckfun(aTHX_ o, namegv, ckobj);
9034 Perl_ck_svconst(pTHX_ OP *o)
9036 PERL_ARGS_ASSERT_CK_SVCONST;
9037 PERL_UNUSED_CONTEXT;
9038 SvREADONLY_on(cSVOPo->op_sv);
9043 Perl_ck_chdir(pTHX_ OP *o)
9045 PERL_ARGS_ASSERT_CK_CHDIR;
9046 if (o->op_flags & OPf_KIDS) {
9047 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9049 if (kid && kid->op_type == OP_CONST &&
9050 (kid->op_private & OPpCONST_BARE))
9052 o->op_flags |= OPf_SPECIAL;
9053 kid->op_private &= ~OPpCONST_STRICT;
9060 Perl_ck_trunc(pTHX_ OP *o)
9062 PERL_ARGS_ASSERT_CK_TRUNC;
9064 if (o->op_flags & OPf_KIDS) {
9065 SVOP *kid = (SVOP*)cUNOPo->op_first;
9067 if (kid->op_type == OP_NULL)
9068 kid = (SVOP*)kid->op_sibling;
9069 if (kid && kid->op_type == OP_CONST &&
9070 (kid->op_private & OPpCONST_BARE))
9072 o->op_flags |= OPf_SPECIAL;
9073 kid->op_private &= ~OPpCONST_STRICT;
9080 Perl_ck_unpack(pTHX_ OP *o)
9082 OP *kid = cLISTOPo->op_first;
9084 PERL_ARGS_ASSERT_CK_UNPACK;
9086 if (kid->op_sibling) {
9087 kid = kid->op_sibling;
9088 if (!kid->op_sibling)
9089 kid->op_sibling = newDEFSVOP();
9095 Perl_ck_substr(pTHX_ OP *o)
9097 PERL_ARGS_ASSERT_CK_SUBSTR;
9100 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9101 OP *kid = cLISTOPo->op_first;
9103 if (kid->op_type == OP_NULL)
9104 kid = kid->op_sibling;
9106 kid->op_flags |= OPf_MOD;
9113 Perl_ck_push(pTHX_ OP *o)
9116 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9120 PERL_ARGS_ASSERT_CK_PUSH;
9122 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9124 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9127 /* If not array or array deref, wrap it with an array deref.
9128 * For OP_CONST, we only wrap arrayrefs */
9130 if ( ( cursor->op_type != OP_PADAV
9131 && cursor->op_type != OP_RV2AV
9132 && cursor->op_type != OP_CONST
9135 ( cursor->op_type == OP_CONST
9136 && SvROK(cSVOPx_sv(cursor))
9137 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9140 proxy = newAVREF(cursor);
9141 if ( cursor == kid ) {
9142 cLISTOPx(o)->op_first = proxy;
9145 cLISTOPx(kid)->op_sibling = proxy;
9147 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9148 cLISTOPx(cursor)->op_sibling = NULL;
9155 Perl_ck_each(pTHX_ OP *o)
9158 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9159 const unsigned orig_type = o->op_type;
9160 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9161 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9162 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9163 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9165 PERL_ARGS_ASSERT_CK_EACH;
9168 switch (kid->op_type) {
9174 CHANGE_TYPE(o, array_type);
9177 if (kid->op_private == OPpCONST_BARE)
9178 /* we let ck_fun treat as hash */
9181 CHANGE_TYPE(o, ref_type);
9184 /* if treating as a reference, defer additional checks to runtime */
9185 return o->op_type == ref_type ? o : ck_fun(o);
9188 /* caller is supposed to assign the return to the
9189 container of the rep_op var */
9191 S_opt_scalarhv(pTHX_ OP *rep_op) {
9195 PERL_ARGS_ASSERT_OPT_SCALARHV;
9197 NewOp(1101, unop, 1, UNOP);
9198 unop->op_type = (OPCODE)OP_BOOLKEYS;
9199 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9200 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9201 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9202 unop->op_first = rep_op;
9203 unop->op_next = rep_op->op_next;
9204 rep_op->op_next = (OP*)unop;
9205 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9206 unop->op_sibling = rep_op->op_sibling;
9207 rep_op->op_sibling = NULL;
9208 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9209 if (rep_op->op_type == OP_PADHV) {
9210 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9211 rep_op->op_flags |= OPf_WANT_LIST;
9216 /* Checks if o acts as an in-place operator on an array. oright points to the
9217 * beginning of the right-hand side. Returns the left-hand side of the
9218 * assignment if o acts in-place, or NULL otherwise. */
9221 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9225 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9228 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9229 || oright->op_next != o
9230 || (oright->op_private & OPpLVAL_INTRO)
9234 /* o2 follows the chain of op_nexts through the LHS of the
9235 * assign (if any) to the aassign op itself */
9237 if (!o2 || o2->op_type != OP_NULL)
9240 if (!o2 || o2->op_type != OP_PUSHMARK)
9243 if (o2 && o2->op_type == OP_GV)
9246 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9247 || (o2->op_private & OPpLVAL_INTRO)
9252 if (!o2 || o2->op_type != OP_NULL)
9255 if (!o2 || o2->op_type != OP_AASSIGN
9256 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9259 /* check that the sort is the first arg on RHS of assign */
9261 o2 = cUNOPx(o2)->op_first;
9262 if (!o2 || o2->op_type != OP_NULL)
9264 o2 = cUNOPx(o2)->op_first;
9265 if (!o2 || o2->op_type != OP_PUSHMARK)
9267 if (o2->op_sibling != o)
9270 /* check the array is the same on both sides */
9271 if (oleft->op_type == OP_RV2AV) {
9272 if (oright->op_type != OP_RV2AV
9273 || !cUNOPx(oright)->op_first
9274 || cUNOPx(oright)->op_first->op_type != OP_GV
9275 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9276 cGVOPx_gv(cUNOPx(oright)->op_first)
9280 else if (oright->op_type != OP_PADAV
9281 || oright->op_targ != oleft->op_targ
9288 /* A peephole optimizer. We visit the ops in the order they're to execute.
9289 * See the comments at the top of this file for more details about when
9290 * peep() is called */
9293 Perl_rpeep(pTHX_ register OP *o)
9296 register OP* oldop = NULL;
9298 if (!o || o->op_opt)
9302 SAVEVPTR(PL_curcop);
9303 for (; o; o = o->op_next) {
9306 /* By default, this op has now been optimised. A couple of cases below
9307 clear this again. */
9310 switch (o->op_type) {
9312 PL_curcop = ((COP*)o); /* for warnings */
9315 PL_curcop = ((COP*)o); /* for warnings */
9317 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9318 to carry two labels. For now, take the easier option, and skip
9319 this optimisation if the first NEXTSTATE has a label. */
9320 if (!CopLABEL((COP*)o)) {
9321 OP *nextop = o->op_next;
9322 while (nextop && nextop->op_type == OP_NULL)
9323 nextop = nextop->op_next;
9325 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9326 COP *firstcop = (COP *)o;
9327 COP *secondcop = (COP *)nextop;
9328 /* We want the COP pointed to by o (and anything else) to
9329 become the next COP down the line. */
9332 firstcop->op_next = secondcop->op_next;
9334 /* Now steal all its pointers, and duplicate the other
9336 firstcop->cop_line = secondcop->cop_line;
9338 firstcop->cop_stashpv = secondcop->cop_stashpv;
9339 firstcop->cop_file = secondcop->cop_file;
9341 firstcop->cop_stash = secondcop->cop_stash;
9342 firstcop->cop_filegv = secondcop->cop_filegv;
9344 firstcop->cop_hints = secondcop->cop_hints;
9345 firstcop->cop_seq = secondcop->cop_seq;
9346 firstcop->cop_warnings = secondcop->cop_warnings;
9347 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9350 secondcop->cop_stashpv = NULL;
9351 secondcop->cop_file = NULL;
9353 secondcop->cop_stash = NULL;
9354 secondcop->cop_filegv = NULL;
9356 secondcop->cop_warnings = NULL;
9357 secondcop->cop_hints_hash = NULL;
9359 /* If we use op_null(), and hence leave an ex-COP, some
9360 warnings are misreported. For example, the compile-time
9361 error in 'use strict; no strict refs;' */
9362 secondcop->op_type = OP_NULL;
9363 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9369 if (cSVOPo->op_private & OPpCONST_STRICT)
9370 no_bareword_allowed(o);
9373 case OP_METHOD_NAMED:
9374 /* Relocate sv to the pad for thread safety.
9375 * Despite being a "constant", the SV is written to,
9376 * for reference counts, sv_upgrade() etc. */
9378 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9379 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9380 /* If op_sv is already a PADTMP then it is being used by
9381 * some pad, so make a copy. */
9382 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9383 SvREADONLY_on(PAD_SVl(ix));
9384 SvREFCNT_dec(cSVOPo->op_sv);
9386 else if (o->op_type != OP_METHOD_NAMED
9387 && cSVOPo->op_sv == &PL_sv_undef) {
9388 /* PL_sv_undef is hack - it's unsafe to store it in the
9389 AV that is the pad, because av_fetch treats values of
9390 PL_sv_undef as a "free" AV entry and will merrily
9391 replace them with a new SV, causing pad_alloc to think
9392 that this pad slot is free. (When, clearly, it is not)
9394 SvOK_off(PAD_SVl(ix));
9395 SvPADTMP_on(PAD_SVl(ix));
9396 SvREADONLY_on(PAD_SVl(ix));
9399 SvREFCNT_dec(PAD_SVl(ix));
9400 SvPADTMP_on(cSVOPo->op_sv);
9401 PAD_SETSV(ix, cSVOPo->op_sv);
9402 /* XXX I don't know how this isn't readonly already. */
9403 SvREADONLY_on(PAD_SVl(ix));
9405 cSVOPo->op_sv = NULL;
9412 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9413 if (o->op_next->op_private & OPpTARGET_MY) {
9414 if (o->op_flags & OPf_STACKED) /* chained concats */
9415 break; /* ignore_optimization */
9417 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9418 o->op_targ = o->op_next->op_targ;
9419 o->op_next->op_targ = 0;
9420 o->op_private |= OPpTARGET_MY;
9423 op_null(o->op_next);
9427 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9428 break; /* Scalar stub must produce undef. List stub is noop */
9432 if (o->op_targ == OP_NEXTSTATE
9433 || o->op_targ == OP_DBSTATE)
9435 PL_curcop = ((COP*)o);
9437 /* XXX: We avoid setting op_seq here to prevent later calls
9438 to rpeep() from mistakenly concluding that optimisation
9439 has already occurred. This doesn't fix the real problem,
9440 though (See 20010220.007). AMS 20010719 */
9441 /* op_seq functionality is now replaced by op_opt */
9448 if (oldop && o->op_next) {
9449 oldop->op_next = o->op_next;
9457 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9458 OP* const pop = (o->op_type == OP_PADAV) ?
9459 o->op_next : o->op_next->op_next;
9461 if (pop && pop->op_type == OP_CONST &&
9462 ((PL_op = pop->op_next)) &&
9463 pop->op_next->op_type == OP_AELEM &&
9464 !(pop->op_next->op_private &
9465 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9466 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9471 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9472 no_bareword_allowed(pop);
9473 if (o->op_type == OP_GV)
9474 op_null(o->op_next);
9475 op_null(pop->op_next);
9477 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9478 o->op_next = pop->op_next->op_next;
9479 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9480 o->op_private = (U8)i;
9481 if (o->op_type == OP_GV) {
9486 o->op_flags |= OPf_SPECIAL;
9487 o->op_type = OP_AELEMFAST;
9492 if (o->op_next->op_type == OP_RV2SV) {
9493 if (!(o->op_next->op_private & OPpDEREF)) {
9494 op_null(o->op_next);
9495 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9497 o->op_next = o->op_next->op_next;
9498 o->op_type = OP_GVSV;
9499 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9502 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9503 GV * const gv = cGVOPo_gv;
9504 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9505 /* XXX could check prototype here instead of just carping */
9506 SV * const sv = sv_newmortal();
9507 gv_efullname3(sv, gv, NULL);
9508 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9509 "%"SVf"() called too early to check prototype",
9513 else if (o->op_next->op_type == OP_READLINE
9514 && o->op_next->op_next->op_type == OP_CONCAT
9515 && (o->op_next->op_next->op_flags & OPf_STACKED))
9517 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9518 o->op_type = OP_RCATLINE;
9519 o->op_flags |= OPf_STACKED;
9520 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9521 op_null(o->op_next->op_next);
9522 op_null(o->op_next);
9532 fop = cUNOP->op_first;
9540 fop = cLOGOP->op_first;
9541 sop = fop->op_sibling;
9542 while (cLOGOP->op_other->op_type == OP_NULL)
9543 cLOGOP->op_other = cLOGOP->op_other->op_next;
9544 CALL_RPEEP(cLOGOP->op_other);
9548 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9550 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9555 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9556 while (nop && nop->op_next) {
9557 switch (nop->op_next->op_type) {
9562 lop = nop = nop->op_next;
9573 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9574 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9575 cLOGOP->op_first = opt_scalarhv(fop);
9576 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9577 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9593 while (cLOGOP->op_other->op_type == OP_NULL)
9594 cLOGOP->op_other = cLOGOP->op_other->op_next;
9595 CALL_RPEEP(cLOGOP->op_other);
9600 while (cLOOP->op_redoop->op_type == OP_NULL)
9601 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9602 CALL_RPEEP(cLOOP->op_redoop);
9603 while (cLOOP->op_nextop->op_type == OP_NULL)
9604 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9605 CALL_RPEEP(cLOOP->op_nextop);
9606 while (cLOOP->op_lastop->op_type == OP_NULL)
9607 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9608 CALL_RPEEP(cLOOP->op_lastop);
9612 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9613 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9614 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9615 cPMOP->op_pmstashstartu.op_pmreplstart
9616 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9617 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9621 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9622 && ckWARN(WARN_SYNTAX))
9624 if (o->op_next->op_sibling) {
9625 const OPCODE type = o->op_next->op_sibling->op_type;
9626 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9627 const line_t oldline = CopLINE(PL_curcop);
9628 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9629 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9630 "Statement unlikely to be reached");
9631 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9632 "\t(Maybe you meant system() when you said exec()?)\n");
9633 CopLINE_set(PL_curcop, oldline);
9644 const char *key = NULL;
9647 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9650 /* Make the CONST have a shared SV */
9651 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9652 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9653 key = SvPV_const(sv, keylen);
9654 lexname = newSVpvn_share(key,
9655 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9661 if ((o->op_private & (OPpLVAL_INTRO)))
9664 rop = (UNOP*)((BINOP*)o)->op_first;
9665 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9667 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9668 if (!SvPAD_TYPED(lexname))
9670 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9671 if (!fields || !GvHV(*fields))
9673 key = SvPV_const(*svp, keylen);
9674 if (!hv_fetch(GvHV(*fields), key,
9675 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9677 Perl_croak(aTHX_ "No such class field \"%s\" "
9678 "in variable %s of type %s",
9679 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9692 SVOP *first_key_op, *key_op;
9694 if ((o->op_private & (OPpLVAL_INTRO))
9695 /* I bet there's always a pushmark... */
9696 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9697 /* hmmm, no optimization if list contains only one key. */
9699 rop = (UNOP*)((LISTOP*)o)->op_last;
9700 if (rop->op_type != OP_RV2HV)
9702 if (rop->op_first->op_type == OP_PADSV)
9703 /* @$hash{qw(keys here)} */
9704 rop = (UNOP*)rop->op_first;
9706 /* @{$hash}{qw(keys here)} */
9707 if (rop->op_first->op_type == OP_SCOPE
9708 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9710 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9716 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9717 if (!SvPAD_TYPED(lexname))
9719 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9720 if (!fields || !GvHV(*fields))
9722 /* Again guessing that the pushmark can be jumped over.... */
9723 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9724 ->op_first->op_sibling;
9725 for (key_op = first_key_op; key_op;
9726 key_op = (SVOP*)key_op->op_sibling) {
9727 if (key_op->op_type != OP_CONST)
9729 svp = cSVOPx_svp(key_op);
9730 key = SvPV_const(*svp, keylen);
9731 if (!hv_fetch(GvHV(*fields), key,
9732 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9734 Perl_croak(aTHX_ "No such class field \"%s\" "
9735 "in variable %s of type %s",
9736 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9745 && ( oldop->op_type == OP_AELEM
9746 || oldop->op_type == OP_PADSV
9747 || oldop->op_type == OP_RV2SV
9748 || oldop->op_type == OP_RV2GV
9749 || oldop->op_type == OP_HELEM
9751 && (oldop->op_private & OPpDEREF)
9753 o->op_private |= OPpDEREFed;
9757 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9761 /* check that RHS of sort is a single plain array */
9762 OP *oright = cUNOPo->op_first;
9763 if (!oright || oright->op_type != OP_PUSHMARK)
9766 /* reverse sort ... can be optimised. */
9767 if (!cUNOPo->op_sibling) {
9768 /* Nothing follows us on the list. */
9769 OP * const reverse = o->op_next;
9771 if (reverse->op_type == OP_REVERSE &&
9772 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9773 OP * const pushmark = cUNOPx(reverse)->op_first;
9774 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9775 && (cUNOPx(pushmark)->op_sibling == o)) {
9776 /* reverse -> pushmark -> sort */
9777 o->op_private |= OPpSORT_REVERSE;
9779 pushmark->op_next = oright->op_next;
9785 /* make @a = sort @a act in-place */
9787 oright = cUNOPx(oright)->op_sibling;
9790 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9791 oright = cUNOPx(oright)->op_sibling;
9794 oleft = is_inplace_av(o, oright);
9798 /* transfer MODishness etc from LHS arg to RHS arg */
9799 oright->op_flags = oleft->op_flags;
9800 o->op_private |= OPpSORT_INPLACE;
9802 /* excise push->gv->rv2av->null->aassign */
9803 o2 = o->op_next->op_next;
9804 op_null(o2); /* PUSHMARK */
9806 if (o2->op_type == OP_GV) {
9807 op_null(o2); /* GV */
9810 op_null(o2); /* RV2AV or PADAV */
9811 o2 = o2->op_next->op_next;
9812 op_null(o2); /* AASSIGN */
9814 o->op_next = o2->op_next;
9820 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9823 LISTOP *enter, *exlist;
9825 /* @a = reverse @a */
9826 if ((oright = cLISTOPo->op_first)
9827 && (oright->op_type == OP_PUSHMARK)
9828 && (oright = oright->op_sibling)
9829 && (oleft = is_inplace_av(o, oright))) {
9832 /* transfer MODishness etc from LHS arg to RHS arg */
9833 oright->op_flags = oleft->op_flags;
9834 o->op_private |= OPpREVERSE_INPLACE;
9836 /* excise push->gv->rv2av->null->aassign */
9837 o2 = o->op_next->op_next;
9838 op_null(o2); /* PUSHMARK */
9840 if (o2->op_type == OP_GV) {
9841 op_null(o2); /* GV */
9844 op_null(o2); /* RV2AV or PADAV */
9845 o2 = o2->op_next->op_next;
9846 op_null(o2); /* AASSIGN */
9848 o->op_next = o2->op_next;
9852 enter = (LISTOP *) o->op_next;
9855 if (enter->op_type == OP_NULL) {
9856 enter = (LISTOP *) enter->op_next;
9860 /* for $a (...) will have OP_GV then OP_RV2GV here.
9861 for (...) just has an OP_GV. */
9862 if (enter->op_type == OP_GV) {
9863 gvop = (OP *) enter;
9864 enter = (LISTOP *) enter->op_next;
9867 if (enter->op_type == OP_RV2GV) {
9868 enter = (LISTOP *) enter->op_next;
9874 if (enter->op_type != OP_ENTERITER)
9877 iter = enter->op_next;
9878 if (!iter || iter->op_type != OP_ITER)
9881 expushmark = enter->op_first;
9882 if (!expushmark || expushmark->op_type != OP_NULL
9883 || expushmark->op_targ != OP_PUSHMARK)
9886 exlist = (LISTOP *) expushmark->op_sibling;
9887 if (!exlist || exlist->op_type != OP_NULL
9888 || exlist->op_targ != OP_LIST)
9891 if (exlist->op_last != o) {
9892 /* Mmm. Was expecting to point back to this op. */
9895 theirmark = exlist->op_first;
9896 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9899 if (theirmark->op_sibling != o) {
9900 /* There's something between the mark and the reverse, eg
9901 for (1, reverse (...))
9906 ourmark = ((LISTOP *)o)->op_first;
9907 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9910 ourlast = ((LISTOP *)o)->op_last;
9911 if (!ourlast || ourlast->op_next != o)
9914 rv2av = ourmark->op_sibling;
9915 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9916 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9917 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9918 /* We're just reversing a single array. */
9919 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9920 enter->op_flags |= OPf_STACKED;
9923 /* We don't have control over who points to theirmark, so sacrifice
9925 theirmark->op_next = ourmark->op_next;
9926 theirmark->op_flags = ourmark->op_flags;
9927 ourlast->op_next = gvop ? gvop : (OP *) enter;
9930 enter->op_private |= OPpITER_REVERSED;
9931 iter->op_private |= OPpITER_REVERSED;
9938 UNOP *refgen, *rv2cv;
9941 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9944 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9947 rv2gv = ((BINOP *)o)->op_last;
9948 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9951 refgen = (UNOP *)((BINOP *)o)->op_first;
9953 if (!refgen || refgen->op_type != OP_REFGEN)
9956 exlist = (LISTOP *)refgen->op_first;
9957 if (!exlist || exlist->op_type != OP_NULL
9958 || exlist->op_targ != OP_LIST)
9961 if (exlist->op_first->op_type != OP_PUSHMARK)
9964 rv2cv = (UNOP*)exlist->op_last;
9966 if (rv2cv->op_type != OP_RV2CV)
9969 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9970 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9971 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9973 o->op_private |= OPpASSIGN_CV_TO_GV;
9974 rv2gv->op_private |= OPpDONT_INIT_GV;
9975 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9983 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9984 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9989 Perl_cpeep_t cpeep =
9990 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
9992 cpeep(aTHX_ o, oldop);
10003 Perl_peep(pTHX_ register OP *o)
10009 =head1 Custom Operators
10011 =for apidoc Ao||custom_op_xop
10012 Return the XOP structure for a given custom op. This function should be
10013 considered internal to OP_NAME and the other access macros: use them instead.
10019 Perl_custom_op_xop(pTHX_ const OP *o)
10025 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10027 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10028 assert(o->op_type == OP_CUSTOM);
10030 /* This is wrong. It assumes a function pointer can be cast to IV,
10031 * which isn't guaranteed, but this is what the old custom OP code
10032 * did. In principle it should be safer to Copy the bytes of the
10033 * pointer into a PV: since the new interface is hidden behind
10034 * functions, this can be changed later if necessary. */
10035 /* Change custom_op_xop if this ever happens */
10036 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10039 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10041 /* assume noone will have just registered a desc */
10042 if (!he && PL_custom_op_names &&
10043 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10048 /* XXX does all this need to be shared mem? */
10049 Newxz(xop, 1, XOP);
10050 pv = SvPV(HeVAL(he), l);
10051 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10052 if (PL_custom_op_descs &&
10053 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10055 pv = SvPV(HeVAL(he), l);
10056 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10058 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10062 if (!he) return &xop_null;
10064 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10069 =for apidoc Ao||custom_op_register
10070 Register a custom op. See L<perlguts/"Custom Operators">.
10076 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10080 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10082 /* see the comment in custom_op_xop */
10083 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10085 if (!PL_custom_ops)
10086 PL_custom_ops = newHV();
10088 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10089 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10094 /* Efficient sub that returns a constant scalar value. */
10096 const_sv_xsub(pTHX_ CV* cv)
10100 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10104 /* diag_listed_as: SKIPME */
10105 Perl_croak(aTHX_ "usage: %s::%s()",
10106 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10119 * c-indentation-style: bsd
10120 * c-basic-offset: 4
10121 * indent-tabs-mode: t
10124 * ex: set ts=8 sts=4 sw=4 noet: