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
1425 This function detects things that can't be modified, such as C<$x+1>, and
1426 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1427 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1429 It also flags things that need to behave specially in an lvalue context,
1430 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1436 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1440 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1443 if (!o || (PL_parser && PL_parser->error_count))
1446 if ((o->op_private & OPpTARGET_MY)
1447 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1452 switch (o->op_type) {
1458 if (!(o->op_private & OPpCONST_ARYBASE))
1461 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1462 CopARYBASE_set(&PL_compiling,
1463 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1467 SAVECOPARYBASE(&PL_compiling);
1468 CopARYBASE_set(&PL_compiling, 0);
1470 else if (type == OP_REFGEN)
1473 Perl_croak(aTHX_ "That use of $[ is unsupported");
1476 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1480 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1481 !(o->op_flags & OPf_STACKED)) {
1482 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1483 /* The default is to set op_private to the number of children,
1484 which for a UNOP such as RV2CV is always 1. And w're using
1485 the bit for a flag in RV2CV, so we need it clear. */
1486 o->op_private &= ~1;
1487 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1488 assert(cUNOPo->op_first->op_type == OP_NULL);
1489 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1492 else if (o->op_private & OPpENTERSUB_NOMOD)
1494 else { /* lvalue subroutine call */
1495 o->op_private |= OPpLVAL_INTRO;
1496 PL_modcount = RETURN_UNLIMITED_NUMBER;
1497 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1498 /* Backward compatibility mode: */
1499 o->op_private |= OPpENTERSUB_INARGS;
1502 else { /* Compile-time error message: */
1503 OP *kid = cUNOPo->op_first;
1507 if (kid->op_type != OP_PUSHMARK) {
1508 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1510 "panic: unexpected lvalue entersub "
1511 "args: type/targ %ld:%"UVuf,
1512 (long)kid->op_type, (UV)kid->op_targ);
1513 kid = kLISTOP->op_first;
1515 while (kid->op_sibling)
1516 kid = kid->op_sibling;
1517 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1519 if (kid->op_type == OP_METHOD_NAMED
1520 || kid->op_type == OP_METHOD)
1524 NewOp(1101, newop, 1, UNOP);
1525 newop->op_type = OP_RV2CV;
1526 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1527 newop->op_first = NULL;
1528 newop->op_next = (OP*)newop;
1529 kid->op_sibling = (OP*)newop;
1530 newop->op_private |= OPpLVAL_INTRO;
1531 newop->op_private &= ~1;
1535 if (kid->op_type != OP_RV2CV)
1537 "panic: unexpected lvalue entersub "
1538 "entry via type/targ %ld:%"UVuf,
1539 (long)kid->op_type, (UV)kid->op_targ);
1540 kid->op_private |= OPpLVAL_INTRO;
1541 break; /* Postpone until runtime */
1545 kid = kUNOP->op_first;
1546 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1547 kid = kUNOP->op_first;
1548 if (kid->op_type == OP_NULL)
1550 "Unexpected constant lvalue entersub "
1551 "entry via type/targ %ld:%"UVuf,
1552 (long)kid->op_type, (UV)kid->op_targ);
1553 if (kid->op_type != OP_GV) {
1554 /* Restore RV2CV to check lvalueness */
1556 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1557 okid->op_next = kid->op_next;
1558 kid->op_next = okid;
1561 okid->op_next = NULL;
1562 okid->op_type = OP_RV2CV;
1564 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1565 okid->op_private |= OPpLVAL_INTRO;
1566 okid->op_private &= ~1;
1570 cv = GvCV(kGVOP_gv);
1580 /* grep, foreach, subcalls, refgen */
1581 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1583 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1584 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1586 : (o->op_type == OP_ENTERSUB
1587 ? "non-lvalue subroutine call"
1589 type ? PL_op_desc[type] : "local"));
1603 case OP_RIGHT_SHIFT:
1612 if (!(o->op_flags & OPf_STACKED))
1619 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1620 op_lvalue(kid, type);
1625 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1626 PL_modcount = RETURN_UNLIMITED_NUMBER;
1627 return o; /* Treat \(@foo) like ordinary list. */
1631 if (scalar_mod_type(o, type))
1633 ref(cUNOPo->op_first, o->op_type);
1637 if (type == OP_LEAVESUBLV)
1638 o->op_private |= OPpMAYBE_LVSUB;
1644 PL_modcount = RETURN_UNLIMITED_NUMBER;
1647 PL_hints |= HINT_BLOCK_SCOPE;
1648 if (type == OP_LEAVESUBLV)
1649 o->op_private |= OPpMAYBE_LVSUB;
1653 ref(cUNOPo->op_first, o->op_type);
1657 PL_hints |= HINT_BLOCK_SCOPE;
1672 PL_modcount = RETURN_UNLIMITED_NUMBER;
1673 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1674 return o; /* Treat \(@foo) like ordinary list. */
1675 if (scalar_mod_type(o, type))
1677 if (type == OP_LEAVESUBLV)
1678 o->op_private |= OPpMAYBE_LVSUB;
1682 if (!type) /* local() */
1683 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1684 PAD_COMPNAME_PV(o->op_targ));
1692 if (type != OP_SASSIGN)
1696 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1701 if (type == OP_LEAVESUBLV)
1702 o->op_private |= OPpMAYBE_LVSUB;
1704 pad_free(o->op_targ);
1705 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1706 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1707 if (o->op_flags & OPf_KIDS)
1708 op_lvalue(cBINOPo->op_first->op_sibling, type);
1713 ref(cBINOPo->op_first, o->op_type);
1714 if (type == OP_ENTERSUB &&
1715 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1716 o->op_private |= OPpLVAL_DEFER;
1717 if (type == OP_LEAVESUBLV)
1718 o->op_private |= OPpMAYBE_LVSUB;
1728 if (o->op_flags & OPf_KIDS)
1729 op_lvalue(cLISTOPo->op_last, type);
1734 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1736 else if (!(o->op_flags & OPf_KIDS))
1738 if (o->op_targ != OP_LIST) {
1739 op_lvalue(cBINOPo->op_first, type);
1745 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1746 op_lvalue(kid, type);
1750 if (type != OP_LEAVESUBLV)
1752 break; /* op_lvalue()ing was handled by ck_return() */
1755 /* [20011101.069] File test operators interpret OPf_REF to mean that
1756 their argument is a filehandle; thus \stat(".") should not set
1758 if (type == OP_REFGEN &&
1759 PL_check[o->op_type] == Perl_ck_ftst)
1762 if (type != OP_LEAVESUBLV)
1763 o->op_flags |= OPf_MOD;
1765 if (type == OP_AASSIGN || type == OP_SASSIGN)
1766 o->op_flags |= OPf_SPECIAL|OPf_REF;
1767 else if (!type) { /* local() */
1770 o->op_private |= OPpLVAL_INTRO;
1771 o->op_flags &= ~OPf_SPECIAL;
1772 PL_hints |= HINT_BLOCK_SCOPE;
1777 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1778 "Useless localization of %s", OP_DESC(o));
1781 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1782 && type != OP_LEAVESUBLV)
1783 o->op_flags |= OPf_REF;
1787 /* Do not use this. It will be removed after 5.14. */
1789 Perl_mod(pTHX_ OP *o, I32 type)
1791 return op_lvalue(o,type);
1796 S_scalar_mod_type(const OP *o, I32 type)
1798 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1802 if (o->op_type == OP_RV2GV)
1826 case OP_RIGHT_SHIFT:
1847 S_is_handle_constructor(const OP *o, I32 numargs)
1849 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1851 switch (o->op_type) {
1859 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1872 S_refkids(pTHX_ OP *o, I32 type)
1874 if (o && o->op_flags & OPf_KIDS) {
1876 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1883 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1888 PERL_ARGS_ASSERT_DOREF;
1890 if (!o || (PL_parser && PL_parser->error_count))
1893 switch (o->op_type) {
1895 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1896 !(o->op_flags & OPf_STACKED)) {
1897 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1898 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1899 assert(cUNOPo->op_first->op_type == OP_NULL);
1900 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1901 o->op_flags |= OPf_SPECIAL;
1902 o->op_private &= ~1;
1907 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1908 doref(kid, type, set_op_ref);
1911 if (type == OP_DEFINED)
1912 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1913 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1916 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1917 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1918 : type == OP_RV2HV ? OPpDEREF_HV
1920 o->op_flags |= OPf_MOD;
1927 o->op_flags |= OPf_REF;
1930 if (type == OP_DEFINED)
1931 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1932 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1938 o->op_flags |= OPf_REF;
1943 if (!(o->op_flags & OPf_KIDS))
1945 doref(cBINOPo->op_first, type, set_op_ref);
1949 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1950 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1951 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1952 : type == OP_RV2HV ? OPpDEREF_HV
1954 o->op_flags |= OPf_MOD;
1964 if (!(o->op_flags & OPf_KIDS))
1966 doref(cLISTOPo->op_last, type, set_op_ref);
1976 S_dup_attrlist(pTHX_ OP *o)
1981 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1983 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1984 * where the first kid is OP_PUSHMARK and the remaining ones
1985 * are OP_CONST. We need to push the OP_CONST values.
1987 if (o->op_type == OP_CONST)
1988 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1990 else if (o->op_type == OP_NULL)
1994 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1996 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1997 if (o->op_type == OP_CONST)
1998 rop = op_append_elem(OP_LIST, rop,
1999 newSVOP(OP_CONST, o->op_flags,
2000 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2007 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2012 PERL_ARGS_ASSERT_APPLY_ATTRS;
2014 /* fake up C<use attributes $pkg,$rv,@attrs> */
2015 ENTER; /* need to protect against side-effects of 'use' */
2016 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2018 #define ATTRSMODULE "attributes"
2019 #define ATTRSMODULE_PM "attributes.pm"
2022 /* Don't force the C<use> if we don't need it. */
2023 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2024 if (svp && *svp != &PL_sv_undef)
2025 NOOP; /* already in %INC */
2027 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2028 newSVpvs(ATTRSMODULE), NULL);
2031 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2032 newSVpvs(ATTRSMODULE),
2034 op_prepend_elem(OP_LIST,
2035 newSVOP(OP_CONST, 0, stashsv),
2036 op_prepend_elem(OP_LIST,
2037 newSVOP(OP_CONST, 0,
2039 dup_attrlist(attrs))));
2045 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2048 OP *pack, *imop, *arg;
2051 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2056 assert(target->op_type == OP_PADSV ||
2057 target->op_type == OP_PADHV ||
2058 target->op_type == OP_PADAV);
2060 /* Ensure that attributes.pm is loaded. */
2061 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2063 /* Need package name for method call. */
2064 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2066 /* Build up the real arg-list. */
2067 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2069 arg = newOP(OP_PADSV, 0);
2070 arg->op_targ = target->op_targ;
2071 arg = op_prepend_elem(OP_LIST,
2072 newSVOP(OP_CONST, 0, stashsv),
2073 op_prepend_elem(OP_LIST,
2074 newUNOP(OP_REFGEN, 0,
2075 op_lvalue(arg, OP_REFGEN)),
2076 dup_attrlist(attrs)));
2078 /* Fake up a method call to import */
2079 meth = newSVpvs_share("import");
2080 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2081 op_append_elem(OP_LIST,
2082 op_prepend_elem(OP_LIST, pack, list(arg)),
2083 newSVOP(OP_METHOD_NAMED, 0, meth)));
2084 imop->op_private |= OPpENTERSUB_NOMOD;
2086 /* Combine the ops. */
2087 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2091 =notfor apidoc apply_attrs_string
2093 Attempts to apply a list of attributes specified by the C<attrstr> and
2094 C<len> arguments to the subroutine identified by the C<cv> argument which
2095 is expected to be associated with the package identified by the C<stashpv>
2096 argument (see L<attributes>). It gets this wrong, though, in that it
2097 does not correctly identify the boundaries of the individual attribute
2098 specifications within C<attrstr>. This is not really intended for the
2099 public API, but has to be listed here for systems such as AIX which
2100 need an explicit export list for symbols. (It's called from XS code
2101 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2102 to respect attribute syntax properly would be welcome.
2108 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2109 const char *attrstr, STRLEN len)
2113 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2116 len = strlen(attrstr);
2120 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2122 const char * const sstr = attrstr;
2123 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2124 attrs = op_append_elem(OP_LIST, attrs,
2125 newSVOP(OP_CONST, 0,
2126 newSVpvn(sstr, attrstr-sstr)));
2130 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2131 newSVpvs(ATTRSMODULE),
2132 NULL, op_prepend_elem(OP_LIST,
2133 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2134 op_prepend_elem(OP_LIST,
2135 newSVOP(OP_CONST, 0,
2136 newRV(MUTABLE_SV(cv))),
2141 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2146 PERL_ARGS_ASSERT_MY_KID;
2148 if (!o || (PL_parser && PL_parser->error_count))
2152 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2153 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2157 if (type == OP_LIST) {
2159 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2160 my_kid(kid, attrs, imopsp);
2161 } else if (type == OP_UNDEF
2167 } else if (type == OP_RV2SV || /* "our" declaration */
2169 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2170 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2171 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2173 PL_parser->in_my == KEY_our
2175 : PL_parser->in_my == KEY_state ? "state" : "my"));
2177 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2178 PL_parser->in_my = FALSE;
2179 PL_parser->in_my_stash = NULL;
2180 apply_attrs(GvSTASH(gv),
2181 (type == OP_RV2SV ? GvSV(gv) :
2182 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2183 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2186 o->op_private |= OPpOUR_INTRO;
2189 else if (type != OP_PADSV &&
2192 type != OP_PUSHMARK)
2194 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2196 PL_parser->in_my == KEY_our
2198 : PL_parser->in_my == KEY_state ? "state" : "my"));
2201 else if (attrs && type != OP_PUSHMARK) {
2204 PL_parser->in_my = FALSE;
2205 PL_parser->in_my_stash = NULL;
2207 /* check for C<my Dog $spot> when deciding package */
2208 stash = PAD_COMPNAME_TYPE(o->op_targ);
2210 stash = PL_curstash;
2211 apply_attrs_my(stash, o, attrs, imopsp);
2213 o->op_flags |= OPf_MOD;
2214 o->op_private |= OPpLVAL_INTRO;
2215 if (PL_parser->in_my == KEY_state)
2216 o->op_private |= OPpPAD_STATE;
2221 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2225 int maybe_scalar = 0;
2227 PERL_ARGS_ASSERT_MY_ATTRS;
2229 /* [perl #17376]: this appears to be premature, and results in code such as
2230 C< our(%x); > executing in list mode rather than void mode */
2232 if (o->op_flags & OPf_PARENS)
2242 o = my_kid(o, attrs, &rops);
2244 if (maybe_scalar && o->op_type == OP_PADSV) {
2245 o = scalar(op_append_list(OP_LIST, rops, o));
2246 o->op_private |= OPpLVAL_INTRO;
2249 o = op_append_list(OP_LIST, o, rops);
2251 PL_parser->in_my = FALSE;
2252 PL_parser->in_my_stash = NULL;
2257 Perl_sawparens(pTHX_ OP *o)
2259 PERL_UNUSED_CONTEXT;
2261 o->op_flags |= OPf_PARENS;
2266 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2270 const OPCODE ltype = left->op_type;
2271 const OPCODE rtype = right->op_type;
2273 PERL_ARGS_ASSERT_BIND_MATCH;
2275 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2276 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2278 const char * const desc
2280 rtype == OP_SUBST || rtype == OP_TRANS
2281 || rtype == OP_TRANSR
2283 ? (int)rtype : OP_MATCH];
2284 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2285 ? "@array" : "%hash");
2286 Perl_warner(aTHX_ packWARN(WARN_MISC),
2287 "Applying %s to %s will act on scalar(%s)",
2288 desc, sample, sample);
2291 if (rtype == OP_CONST &&
2292 cSVOPx(right)->op_private & OPpCONST_BARE &&
2293 cSVOPx(right)->op_private & OPpCONST_STRICT)
2295 no_bareword_allowed(right);
2298 /* !~ doesn't make sense with /r, so error on it for now */
2299 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2301 yyerror("Using !~ with s///r doesn't make sense");
2302 if (rtype == OP_TRANSR && type == OP_NOT)
2303 yyerror("Using !~ with tr///r doesn't make sense");
2305 ismatchop = (rtype == OP_MATCH ||
2306 rtype == OP_SUBST ||
2307 rtype == OP_TRANS || rtype == OP_TRANSR)
2308 && !(right->op_flags & OPf_SPECIAL);
2309 if (ismatchop && right->op_private & OPpTARGET_MY) {
2311 right->op_private &= ~OPpTARGET_MY;
2313 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2316 right->op_flags |= OPf_STACKED;
2317 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2318 ! (rtype == OP_TRANS &&
2319 right->op_private & OPpTRANS_IDENTICAL) &&
2320 ! (rtype == OP_SUBST &&
2321 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2322 newleft = op_lvalue(left, rtype);
2325 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2326 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2328 o = op_prepend_elem(rtype, scalar(newleft), right);
2330 return newUNOP(OP_NOT, 0, scalar(o));
2334 return bind_match(type, left,
2335 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2339 Perl_invert(pTHX_ OP *o)
2343 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2347 =for apidoc Amx|OP *|op_scope|OP *o
2349 Wraps up an op tree with some additional ops so that at runtime a dynamic
2350 scope will be created. The original ops run in the new dynamic scope,
2351 and then, provided that they exit normally, the scope will be unwound.
2352 The additional ops used to create and unwind the dynamic scope will
2353 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2354 instead if the ops are simple enough to not need the full dynamic scope
2361 Perl_op_scope(pTHX_ OP *o)
2365 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2366 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2367 o->op_type = OP_LEAVE;
2368 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2370 else if (o->op_type == OP_LINESEQ) {
2372 o->op_type = OP_SCOPE;
2373 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2374 kid = ((LISTOP*)o)->op_first;
2375 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2378 /* The following deals with things like 'do {1 for 1}' */
2379 kid = kid->op_sibling;
2381 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2386 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2392 Perl_block_start(pTHX_ int full)
2395 const int retval = PL_savestack_ix;
2397 pad_block_start(full);
2399 PL_hints &= ~HINT_BLOCK_SCOPE;
2400 SAVECOMPILEWARNINGS();
2401 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2403 CALL_BLOCK_HOOKS(bhk_start, full);
2409 Perl_block_end(pTHX_ I32 floor, OP *seq)
2412 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2413 OP* retval = scalarseq(seq);
2415 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2418 CopHINTS_set(&PL_compiling, PL_hints);
2420 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2423 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2429 =head1 Compile-time scope hooks
2431 =for apidoc Ao||blockhook_register
2433 Register a set of hooks to be called when the Perl lexical scope changes
2434 at compile time. See L<perlguts/"Compile-time scope hooks">.
2440 Perl_blockhook_register(pTHX_ BHK *hk)
2442 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2444 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2451 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2452 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2453 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2456 OP * const o = newOP(OP_PADSV, 0);
2457 o->op_targ = offset;
2463 Perl_newPROG(pTHX_ OP *o)
2467 PERL_ARGS_ASSERT_NEWPROG;
2472 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2473 ((PL_in_eval & EVAL_KEEPERR)
2474 ? OPf_SPECIAL : 0), o);
2475 /* don't use LINKLIST, since PL_eval_root might indirect through
2476 * a rather expensive function call and LINKLIST evaluates its
2477 * argument more than once */
2478 PL_eval_start = op_linklist(PL_eval_root);
2479 PL_eval_root->op_private |= OPpREFCOUNTED;
2480 OpREFCNT_set(PL_eval_root, 1);
2481 PL_eval_root->op_next = 0;
2482 CALL_PEEP(PL_eval_start);
2485 if (o->op_type == OP_STUB) {
2486 PL_comppad_name = 0;
2488 S_op_destroy(aTHX_ o);
2491 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2492 PL_curcop = &PL_compiling;
2493 PL_main_start = LINKLIST(PL_main_root);
2494 PL_main_root->op_private |= OPpREFCOUNTED;
2495 OpREFCNT_set(PL_main_root, 1);
2496 PL_main_root->op_next = 0;
2497 CALL_PEEP(PL_main_start);
2500 /* Register with debugger */
2502 CV * const cv = get_cvs("DB::postponed", 0);
2506 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2508 call_sv(MUTABLE_SV(cv), G_DISCARD);
2515 Perl_localize(pTHX_ OP *o, I32 lex)
2519 PERL_ARGS_ASSERT_LOCALIZE;
2521 if (o->op_flags & OPf_PARENS)
2522 /* [perl #17376]: this appears to be premature, and results in code such as
2523 C< our(%x); > executing in list mode rather than void mode */
2530 if ( PL_parser->bufptr > PL_parser->oldbufptr
2531 && PL_parser->bufptr[-1] == ','
2532 && ckWARN(WARN_PARENTHESIS))
2534 char *s = PL_parser->bufptr;
2537 /* some heuristics to detect a potential error */
2538 while (*s && (strchr(", \t\n", *s)))
2542 if (*s && strchr("@$%*", *s) && *++s
2543 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2546 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2548 while (*s && (strchr(", \t\n", *s)))
2554 if (sigil && (*s == ';' || *s == '=')) {
2555 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2556 "Parentheses missing around \"%s\" list",
2558 ? (PL_parser->in_my == KEY_our
2560 : PL_parser->in_my == KEY_state
2570 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2571 PL_parser->in_my = FALSE;
2572 PL_parser->in_my_stash = NULL;
2577 Perl_jmaybe(pTHX_ OP *o)
2579 PERL_ARGS_ASSERT_JMAYBE;
2581 if (o->op_type == OP_LIST) {
2583 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2584 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2590 S_fold_constants(pTHX_ register OP *o)
2593 register OP * VOL curop;
2595 VOL I32 type = o->op_type;
2600 SV * const oldwarnhook = PL_warnhook;
2601 SV * const olddiehook = PL_diehook;
2605 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2607 if (PL_opargs[type] & OA_RETSCALAR)
2609 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2610 o->op_targ = pad_alloc(type, SVs_PADTMP);
2612 /* integerize op, unless it happens to be C<-foo>.
2613 * XXX should pp_i_negate() do magic string negation instead? */
2614 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2615 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2616 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2618 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2621 if (!(PL_opargs[type] & OA_FOLDCONST))
2626 /* XXX might want a ck_negate() for this */
2627 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2639 /* XXX what about the numeric ops? */
2640 if (PL_hints & HINT_LOCALE)
2645 if (PL_parser && PL_parser->error_count)
2646 goto nope; /* Don't try to run w/ errors */
2648 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2649 const OPCODE type = curop->op_type;
2650 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2652 type != OP_SCALAR &&
2654 type != OP_PUSHMARK)
2660 curop = LINKLIST(o);
2661 old_next = o->op_next;
2665 oldscope = PL_scopestack_ix;
2666 create_eval_scope(G_FAKINGEVAL);
2668 /* Verify that we don't need to save it: */
2669 assert(PL_curcop == &PL_compiling);
2670 StructCopy(&PL_compiling, ¬_compiling, COP);
2671 PL_curcop = ¬_compiling;
2672 /* The above ensures that we run with all the correct hints of the
2673 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2674 assert(IN_PERL_RUNTIME);
2675 PL_warnhook = PERL_WARNHOOK_FATAL;
2682 sv = *(PL_stack_sp--);
2683 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2684 pad_swipe(o->op_targ, FALSE);
2685 else if (SvTEMP(sv)) { /* grab mortal temp? */
2686 SvREFCNT_inc_simple_void(sv);
2691 /* Something tried to die. Abandon constant folding. */
2692 /* Pretend the error never happened. */
2694 o->op_next = old_next;
2698 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2699 PL_warnhook = oldwarnhook;
2700 PL_diehook = olddiehook;
2701 /* XXX note that this croak may fail as we've already blown away
2702 * the stack - eg any nested evals */
2703 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2706 PL_warnhook = oldwarnhook;
2707 PL_diehook = olddiehook;
2708 PL_curcop = &PL_compiling;
2710 if (PL_scopestack_ix > oldscope)
2711 delete_eval_scope();
2720 if (type == OP_RV2GV)
2721 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2723 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2724 op_getmad(o,newop,'f');
2732 S_gen_constant_list(pTHX_ register OP *o)
2736 const I32 oldtmps_floor = PL_tmps_floor;
2739 if (PL_parser && PL_parser->error_count)
2740 return o; /* Don't attempt to run with errors */
2742 PL_op = curop = LINKLIST(o);
2748 assert (!(curop->op_flags & OPf_SPECIAL));
2749 assert(curop->op_type == OP_RANGE);
2751 PL_tmps_floor = oldtmps_floor;
2753 o->op_type = OP_RV2AV;
2754 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2755 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2756 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2757 o->op_opt = 0; /* needs to be revisited in rpeep() */
2758 curop = ((UNOP*)o)->op_first;
2759 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2761 op_getmad(curop,o,'O');
2770 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2773 if (!o || o->op_type != OP_LIST)
2774 o = newLISTOP(OP_LIST, 0, o, NULL);
2776 o->op_flags &= ~OPf_WANT;
2778 if (!(PL_opargs[type] & OA_MARK))
2779 op_null(cLISTOPo->op_first);
2781 o->op_type = (OPCODE)type;
2782 o->op_ppaddr = PL_ppaddr[type];
2783 o->op_flags |= flags;
2785 o = CHECKOP(type, o);
2786 if (o->op_type != (unsigned)type)
2789 return fold_constants(o);
2793 =head1 Optree Manipulation Functions
2796 /* List constructors */
2799 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2801 Append an item to the list of ops contained directly within a list-type
2802 op, returning the lengthened list. I<first> is the list-type op,
2803 and I<last> is the op to append to the list. I<optype> specifies the
2804 intended opcode for the list. If I<first> is not already a list of the
2805 right type, it will be upgraded into one. If either I<first> or I<last>
2806 is null, the other is returned unchanged.
2812 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2820 if (first->op_type != (unsigned)type
2821 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2823 return newLISTOP(type, 0, first, last);
2826 if (first->op_flags & OPf_KIDS)
2827 ((LISTOP*)first)->op_last->op_sibling = last;
2829 first->op_flags |= OPf_KIDS;
2830 ((LISTOP*)first)->op_first = last;
2832 ((LISTOP*)first)->op_last = last;
2837 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2839 Concatenate the lists of ops contained directly within two list-type ops,
2840 returning the combined list. I<first> and I<last> are the list-type ops
2841 to concatenate. I<optype> specifies the intended opcode for the list.
2842 If either I<first> or I<last> is not already a list of the right type,
2843 it will be upgraded into one. If either I<first> or I<last> is null,
2844 the other is returned unchanged.
2850 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2858 if (first->op_type != (unsigned)type)
2859 return op_prepend_elem(type, first, last);
2861 if (last->op_type != (unsigned)type)
2862 return op_append_elem(type, first, last);
2864 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2865 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2866 first->op_flags |= (last->op_flags & OPf_KIDS);
2869 if (((LISTOP*)last)->op_first && first->op_madprop) {
2870 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2872 while (mp->mad_next)
2874 mp->mad_next = first->op_madprop;
2877 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2880 first->op_madprop = last->op_madprop;
2881 last->op_madprop = 0;
2884 S_op_destroy(aTHX_ last);
2890 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2892 Prepend an item to the list of ops contained directly within a list-type
2893 op, returning the lengthened list. I<first> is the op to prepend to the
2894 list, and I<last> is the list-type op. I<optype> specifies the intended
2895 opcode for the list. If I<last> is not already a list of the right type,
2896 it will be upgraded into one. If either I<first> or I<last> is null,
2897 the other is returned unchanged.
2903 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2911 if (last->op_type == (unsigned)type) {
2912 if (type == OP_LIST) { /* already a PUSHMARK there */
2913 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2914 ((LISTOP*)last)->op_first->op_sibling = first;
2915 if (!(first->op_flags & OPf_PARENS))
2916 last->op_flags &= ~OPf_PARENS;
2919 if (!(last->op_flags & OPf_KIDS)) {
2920 ((LISTOP*)last)->op_last = first;
2921 last->op_flags |= OPf_KIDS;
2923 first->op_sibling = ((LISTOP*)last)->op_first;
2924 ((LISTOP*)last)->op_first = first;
2926 last->op_flags |= OPf_KIDS;
2930 return newLISTOP(type, 0, first, last);
2938 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2941 Newxz(tk, 1, TOKEN);
2942 tk->tk_type = (OPCODE)optype;
2943 tk->tk_type = 12345;
2945 tk->tk_mad = madprop;
2950 Perl_token_free(pTHX_ TOKEN* tk)
2952 PERL_ARGS_ASSERT_TOKEN_FREE;
2954 if (tk->tk_type != 12345)
2956 mad_free(tk->tk_mad);
2961 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2966 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2968 if (tk->tk_type != 12345) {
2969 Perl_warner(aTHX_ packWARN(WARN_MISC),
2970 "Invalid TOKEN object ignored");
2977 /* faked up qw list? */
2979 tm->mad_type == MAD_SV &&
2980 SvPVX((SV *)tm->mad_val)[0] == 'q')
2987 /* pretend constant fold didn't happen? */
2988 if (mp->mad_key == 'f' &&
2989 (o->op_type == OP_CONST ||
2990 o->op_type == OP_GV) )
2992 token_getmad(tk,(OP*)mp->mad_val,slot);
3006 if (mp->mad_key == 'X')
3007 mp->mad_key = slot; /* just change the first one */
3017 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3026 /* pretend constant fold didn't happen? */
3027 if (mp->mad_key == 'f' &&
3028 (o->op_type == OP_CONST ||
3029 o->op_type == OP_GV) )
3031 op_getmad(from,(OP*)mp->mad_val,slot);
3038 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3041 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3047 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3056 /* pretend constant fold didn't happen? */
3057 if (mp->mad_key == 'f' &&
3058 (o->op_type == OP_CONST ||
3059 o->op_type == OP_GV) )
3061 op_getmad(from,(OP*)mp->mad_val,slot);
3068 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3071 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3075 PerlIO_printf(PerlIO_stderr(),
3076 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3082 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3100 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3104 addmad(tm, &(o->op_madprop), slot);
3108 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3129 Perl_newMADsv(pTHX_ char key, SV* sv)
3131 PERL_ARGS_ASSERT_NEWMADSV;
3133 return newMADPROP(key, MAD_SV, sv, 0);
3137 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3140 Newxz(mp, 1, MADPROP);
3143 mp->mad_vlen = vlen;
3144 mp->mad_type = type;
3146 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3151 Perl_mad_free(pTHX_ MADPROP* mp)
3153 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3157 mad_free(mp->mad_next);
3158 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3159 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3160 switch (mp->mad_type) {
3164 Safefree((char*)mp->mad_val);
3167 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3168 op_free((OP*)mp->mad_val);
3171 sv_free(MUTABLE_SV(mp->mad_val));
3174 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3183 =head1 Optree construction
3185 =for apidoc Am|OP *|newNULLLIST
3187 Constructs, checks, and returns a new C<stub> op, which represents an
3188 empty list expression.
3194 Perl_newNULLLIST(pTHX)
3196 return newOP(OP_STUB, 0);
3200 S_force_list(pTHX_ OP *o)
3202 if (!o || o->op_type != OP_LIST)
3203 o = newLISTOP(OP_LIST, 0, o, NULL);
3209 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3211 Constructs, checks, and returns an op of any list type. I<type> is
3212 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3213 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3214 supply up to two ops to be direct children of the list op; they are
3215 consumed by this function and become part of the constructed op tree.
3221 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3226 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3228 NewOp(1101, listop, 1, LISTOP);
3230 listop->op_type = (OPCODE)type;
3231 listop->op_ppaddr = PL_ppaddr[type];
3234 listop->op_flags = (U8)flags;
3238 else if (!first && last)
3241 first->op_sibling = last;
3242 listop->op_first = first;
3243 listop->op_last = last;
3244 if (type == OP_LIST) {
3245 OP* const pushop = newOP(OP_PUSHMARK, 0);
3246 pushop->op_sibling = first;
3247 listop->op_first = pushop;
3248 listop->op_flags |= OPf_KIDS;
3250 listop->op_last = pushop;
3253 return CHECKOP(type, listop);
3257 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3259 Constructs, checks, and returns an op of any base type (any type that
3260 has no extra fields). I<type> is the opcode. I<flags> gives the
3261 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3268 Perl_newOP(pTHX_ I32 type, I32 flags)
3273 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3274 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3275 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3276 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3278 NewOp(1101, o, 1, OP);
3279 o->op_type = (OPCODE)type;
3280 o->op_ppaddr = PL_ppaddr[type];
3281 o->op_flags = (U8)flags;
3283 o->op_latefreed = 0;
3287 o->op_private = (U8)(0 | (flags >> 8));
3288 if (PL_opargs[type] & OA_RETSCALAR)
3290 if (PL_opargs[type] & OA_TARGET)
3291 o->op_targ = pad_alloc(type, SVs_PADTMP);
3292 return CHECKOP(type, o);
3296 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3298 Constructs, checks, and returns an op of any unary type. I<type> is
3299 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3300 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3301 bits, the eight bits of C<op_private>, except that the bit with value 1
3302 is automatically set. I<first> supplies an optional op to be the direct
3303 child of the unary op; it is consumed by this function and become part
3304 of the constructed op tree.
3310 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3315 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3316 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3317 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3318 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3319 || type == OP_SASSIGN
3320 || type == OP_ENTERTRY
3321 || type == OP_NULL );
3324 first = newOP(OP_STUB, 0);
3325 if (PL_opargs[type] & OA_MARK)
3326 first = force_list(first);
3328 NewOp(1101, unop, 1, UNOP);
3329 unop->op_type = (OPCODE)type;
3330 unop->op_ppaddr = PL_ppaddr[type];
3331 unop->op_first = first;
3332 unop->op_flags = (U8)(flags | OPf_KIDS);
3333 unop->op_private = (U8)(1 | (flags >> 8));
3334 unop = (UNOP*) CHECKOP(type, unop);
3338 return fold_constants((OP *) unop);
3342 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3344 Constructs, checks, and returns an op of any binary type. I<type>
3345 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3346 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3347 the eight bits of C<op_private>, except that the bit with value 1 or
3348 2 is automatically set as required. I<first> and I<last> supply up to
3349 two ops to be the direct children of the binary op; they are consumed
3350 by this function and become part of the constructed op tree.
3356 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3361 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3362 || type == OP_SASSIGN || type == OP_NULL );
3364 NewOp(1101, binop, 1, BINOP);
3367 first = newOP(OP_NULL, 0);
3369 binop->op_type = (OPCODE)type;
3370 binop->op_ppaddr = PL_ppaddr[type];
3371 binop->op_first = first;
3372 binop->op_flags = (U8)(flags | OPf_KIDS);
3375 binop->op_private = (U8)(1 | (flags >> 8));
3378 binop->op_private = (U8)(2 | (flags >> 8));
3379 first->op_sibling = last;
3382 binop = (BINOP*)CHECKOP(type, binop);
3383 if (binop->op_next || binop->op_type != (OPCODE)type)
3386 binop->op_last = binop->op_first->op_sibling;
3388 return fold_constants((OP *)binop);
3391 static int uvcompare(const void *a, const void *b)
3392 __attribute__nonnull__(1)
3393 __attribute__nonnull__(2)
3394 __attribute__pure__;
3395 static int uvcompare(const void *a, const void *b)
3397 if (*((const UV *)a) < (*(const UV *)b))
3399 if (*((const UV *)a) > (*(const UV *)b))
3401 if (*((const UV *)a+1) < (*(const UV *)b+1))
3403 if (*((const UV *)a+1) > (*(const UV *)b+1))
3409 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3412 SV * const tstr = ((SVOP*)expr)->op_sv;
3415 (repl->op_type == OP_NULL)
3416 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3418 ((SVOP*)repl)->op_sv;
3421 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3422 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3426 register short *tbl;
3428 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3429 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3430 I32 del = o->op_private & OPpTRANS_DELETE;
3433 PERL_ARGS_ASSERT_PMTRANS;
3435 PL_hints |= HINT_BLOCK_SCOPE;
3438 o->op_private |= OPpTRANS_FROM_UTF;
3441 o->op_private |= OPpTRANS_TO_UTF;
3443 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3444 SV* const listsv = newSVpvs("# comment\n");
3446 const U8* tend = t + tlen;
3447 const U8* rend = r + rlen;
3461 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3462 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3465 const U32 flags = UTF8_ALLOW_DEFAULT;
3469 t = tsave = bytes_to_utf8(t, &len);
3472 if (!to_utf && rlen) {
3474 r = rsave = bytes_to_utf8(r, &len);
3478 /* There are several snags with this code on EBCDIC:
3479 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3480 2. scan_const() in toke.c has encoded chars in native encoding which makes
3481 ranges at least in EBCDIC 0..255 range the bottom odd.
3485 U8 tmpbuf[UTF8_MAXBYTES+1];
3488 Newx(cp, 2*tlen, UV);
3490 transv = newSVpvs("");
3492 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3494 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3496 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3500 cp[2*i+1] = cp[2*i];
3504 qsort(cp, i, 2*sizeof(UV), uvcompare);
3505 for (j = 0; j < i; j++) {
3507 diff = val - nextmin;
3509 t = uvuni_to_utf8(tmpbuf,nextmin);
3510 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3512 U8 range_mark = UTF_TO_NATIVE(0xff);
3513 t = uvuni_to_utf8(tmpbuf, val - 1);
3514 sv_catpvn(transv, (char *)&range_mark, 1);
3515 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3522 t = uvuni_to_utf8(tmpbuf,nextmin);
3523 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3525 U8 range_mark = UTF_TO_NATIVE(0xff);
3526 sv_catpvn(transv, (char *)&range_mark, 1);
3528 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3529 UNICODE_ALLOW_SUPER);
3530 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3531 t = (const U8*)SvPVX_const(transv);
3532 tlen = SvCUR(transv);
3536 else if (!rlen && !del) {
3537 r = t; rlen = tlen; rend = tend;
3540 if ((!rlen && !del) || t == r ||
3541 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3543 o->op_private |= OPpTRANS_IDENTICAL;
3547 while (t < tend || tfirst <= tlast) {
3548 /* see if we need more "t" chars */
3549 if (tfirst > tlast) {
3550 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3552 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3554 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3561 /* now see if we need more "r" chars */
3562 if (rfirst > rlast) {
3564 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3566 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3568 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3577 rfirst = rlast = 0xffffffff;
3581 /* now see which range will peter our first, if either. */
3582 tdiff = tlast - tfirst;
3583 rdiff = rlast - rfirst;
3590 if (rfirst == 0xffffffff) {
3591 diff = tdiff; /* oops, pretend rdiff is infinite */
3593 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3594 (long)tfirst, (long)tlast);
3596 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3600 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3601 (long)tfirst, (long)(tfirst + diff),
3604 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3605 (long)tfirst, (long)rfirst);
3607 if (rfirst + diff > max)
3608 max = rfirst + diff;
3610 grows = (tfirst < rfirst &&
3611 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3623 else if (max > 0xff)
3628 PerlMemShared_free(cPVOPo->op_pv);
3629 cPVOPo->op_pv = NULL;
3631 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3633 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3634 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3635 PAD_SETSV(cPADOPo->op_padix, swash);
3637 SvREADONLY_on(swash);
3639 cSVOPo->op_sv = swash;
3641 SvREFCNT_dec(listsv);
3642 SvREFCNT_dec(transv);
3644 if (!del && havefinal && rlen)
3645 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3646 newSVuv((UV)final), 0);
3649 o->op_private |= OPpTRANS_GROWS;
3655 op_getmad(expr,o,'e');
3656 op_getmad(repl,o,'r');
3664 tbl = (short*)cPVOPo->op_pv;
3666 Zero(tbl, 256, short);
3667 for (i = 0; i < (I32)tlen; i++)
3669 for (i = 0, j = 0; i < 256; i++) {
3671 if (j >= (I32)rlen) {
3680 if (i < 128 && r[j] >= 128)
3690 o->op_private |= OPpTRANS_IDENTICAL;
3692 else if (j >= (I32)rlen)
3697 PerlMemShared_realloc(tbl,
3698 (0x101+rlen-j) * sizeof(short));
3699 cPVOPo->op_pv = (char*)tbl;
3701 tbl[0x100] = (short)(rlen - j);
3702 for (i=0; i < (I32)rlen - j; i++)
3703 tbl[0x101+i] = r[j+i];
3707 if (!rlen && !del) {
3710 o->op_private |= OPpTRANS_IDENTICAL;
3712 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3713 o->op_private |= OPpTRANS_IDENTICAL;
3715 for (i = 0; i < 256; i++)
3717 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3718 if (j >= (I32)rlen) {
3720 if (tbl[t[i]] == -1)
3726 if (tbl[t[i]] == -1) {
3727 if (t[i] < 128 && r[j] >= 128)
3734 if(del && rlen == tlen) {
3735 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3736 } else if(rlen > tlen) {
3737 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3741 o->op_private |= OPpTRANS_GROWS;
3743 op_getmad(expr,o,'e');
3744 op_getmad(repl,o,'r');
3754 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3756 Constructs, checks, and returns an op of any pattern matching type.
3757 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3758 and, shifted up eight bits, the eight bits of C<op_private>.
3764 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3769 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3771 NewOp(1101, pmop, 1, PMOP);
3772 pmop->op_type = (OPCODE)type;
3773 pmop->op_ppaddr = PL_ppaddr[type];
3774 pmop->op_flags = (U8)flags;
3775 pmop->op_private = (U8)(0 | (flags >> 8));
3777 if (PL_hints & HINT_RE_TAINT)
3778 pmop->op_pmflags |= PMf_RETAINT;
3779 if (PL_hints & HINT_LOCALE) {
3780 pmop->op_pmflags |= PMf_LOCALE;
3782 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3783 pmop->op_pmflags |= RXf_PMf_UNICODE;
3785 if (PL_hints & HINT_RE_FLAGS) {
3786 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3787 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3789 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3790 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3791 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3793 if (reflags && SvOK(reflags)) {
3794 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3795 pmop->op_pmflags |= SvIV(reflags);
3801 assert(SvPOK(PL_regex_pad[0]));
3802 if (SvCUR(PL_regex_pad[0])) {
3803 /* Pop off the "packed" IV from the end. */
3804 SV *const repointer_list = PL_regex_pad[0];
3805 const char *p = SvEND(repointer_list) - sizeof(IV);
3806 const IV offset = *((IV*)p);
3808 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3810 SvEND_set(repointer_list, p);
3812 pmop->op_pmoffset = offset;
3813 /* This slot should be free, so assert this: */
3814 assert(PL_regex_pad[offset] == &PL_sv_undef);
3816 SV * const repointer = &PL_sv_undef;
3817 av_push(PL_regex_padav, repointer);
3818 pmop->op_pmoffset = av_len(PL_regex_padav);
3819 PL_regex_pad = AvARRAY(PL_regex_padav);
3823 return CHECKOP(type, pmop);
3826 /* Given some sort of match op o, and an expression expr containing a
3827 * pattern, either compile expr into a regex and attach it to o (if it's
3828 * constant), or convert expr into a runtime regcomp op sequence (if it's
3831 * isreg indicates that the pattern is part of a regex construct, eg
3832 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3833 * split "pattern", which aren't. In the former case, expr will be a list
3834 * if the pattern contains more than one term (eg /a$b/) or if it contains
3835 * a replacement, ie s/// or tr///.
3839 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3844 I32 repl_has_vars = 0;
3848 PERL_ARGS_ASSERT_PMRUNTIME;
3851 o->op_type == OP_SUBST
3852 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3854 /* last element in list is the replacement; pop it */
3856 repl = cLISTOPx(expr)->op_last;
3857 kid = cLISTOPx(expr)->op_first;
3858 while (kid->op_sibling != repl)
3859 kid = kid->op_sibling;
3860 kid->op_sibling = NULL;
3861 cLISTOPx(expr)->op_last = kid;
3864 if (isreg && expr->op_type == OP_LIST &&
3865 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3867 /* convert single element list to element */
3868 OP* const oe = expr;
3869 expr = cLISTOPx(oe)->op_first->op_sibling;
3870 cLISTOPx(oe)->op_first->op_sibling = NULL;
3871 cLISTOPx(oe)->op_last = NULL;
3875 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3876 return pmtrans(o, expr, repl);
3879 reglist = isreg && expr->op_type == OP_LIST;
3883 PL_hints |= HINT_BLOCK_SCOPE;
3886 if (expr->op_type == OP_CONST) {
3887 SV *pat = ((SVOP*)expr)->op_sv;
3888 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3890 if (o->op_flags & OPf_SPECIAL)
3891 pm_flags |= RXf_SPLIT;
3894 assert (SvUTF8(pat));
3895 } else if (SvUTF8(pat)) {
3896 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3897 trapped in use 'bytes'? */
3898 /* Make a copy of the octet sequence, but without the flag on, as
3899 the compiler now honours the SvUTF8 flag on pat. */
3901 const char *const p = SvPV(pat, len);
3902 pat = newSVpvn_flags(p, len, SVs_TEMP);
3905 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3908 op_getmad(expr,(OP*)pm,'e');
3914 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3915 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3917 : OP_REGCMAYBE),0,expr);
3919 NewOp(1101, rcop, 1, LOGOP);
3920 rcop->op_type = OP_REGCOMP;
3921 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3922 rcop->op_first = scalar(expr);
3923 rcop->op_flags |= OPf_KIDS
3924 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3925 | (reglist ? OPf_STACKED : 0);
3926 rcop->op_private = 1;
3929 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3931 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3934 /* establish postfix order */
3935 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3937 rcop->op_next = expr;
3938 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3941 rcop->op_next = LINKLIST(expr);
3942 expr->op_next = (OP*)rcop;
3945 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3950 if (pm->op_pmflags & PMf_EVAL) {
3952 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3953 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3955 else if (repl->op_type == OP_CONST)
3959 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3960 if (curop->op_type == OP_SCOPE
3961 || curop->op_type == OP_LEAVE
3962 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3963 if (curop->op_type == OP_GV) {
3964 GV * const gv = cGVOPx_gv(curop);
3966 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3969 else if (curop->op_type == OP_RV2CV)
3971 else if (curop->op_type == OP_RV2SV ||
3972 curop->op_type == OP_RV2AV ||
3973 curop->op_type == OP_RV2HV ||
3974 curop->op_type == OP_RV2GV) {
3975 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3978 else if (curop->op_type == OP_PADSV ||
3979 curop->op_type == OP_PADAV ||
3980 curop->op_type == OP_PADHV ||
3981 curop->op_type == OP_PADANY)
3985 else if (curop->op_type == OP_PUSHRE)
3986 NOOP; /* Okay here, dangerous in newASSIGNOP */
3996 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3998 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3999 op_prepend_elem(o->op_type, scalar(repl), o);
4002 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4003 pm->op_pmflags |= PMf_MAYBE_CONST;
4005 NewOp(1101, rcop, 1, LOGOP);
4006 rcop->op_type = OP_SUBSTCONT;
4007 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4008 rcop->op_first = scalar(repl);
4009 rcop->op_flags |= OPf_KIDS;
4010 rcop->op_private = 1;
4013 /* establish postfix order */
4014 rcop->op_next = LINKLIST(repl);
4015 repl->op_next = (OP*)rcop;
4017 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4018 assert(!(pm->op_pmflags & PMf_ONCE));
4019 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4028 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4030 Constructs, checks, and returns an op of any type that involves an
4031 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4032 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4033 takes ownership of one reference to it.
4039 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4044 PERL_ARGS_ASSERT_NEWSVOP;
4046 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4047 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4048 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4050 NewOp(1101, svop, 1, SVOP);
4051 svop->op_type = (OPCODE)type;
4052 svop->op_ppaddr = PL_ppaddr[type];
4054 svop->op_next = (OP*)svop;
4055 svop->op_flags = (U8)flags;
4056 if (PL_opargs[type] & OA_RETSCALAR)
4058 if (PL_opargs[type] & OA_TARGET)
4059 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4060 return CHECKOP(type, svop);
4066 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4068 Constructs, checks, and returns an op of any type that involves a
4069 reference to a pad element. I<type> is the opcode. I<flags> gives the
4070 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4071 is populated with I<sv>; this function takes ownership of one reference
4074 This function only exists if Perl has been compiled to use ithreads.
4080 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4085 PERL_ARGS_ASSERT_NEWPADOP;
4087 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4088 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4089 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4091 NewOp(1101, padop, 1, PADOP);
4092 padop->op_type = (OPCODE)type;
4093 padop->op_ppaddr = PL_ppaddr[type];
4094 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4095 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4096 PAD_SETSV(padop->op_padix, sv);
4099 padop->op_next = (OP*)padop;
4100 padop->op_flags = (U8)flags;
4101 if (PL_opargs[type] & OA_RETSCALAR)
4103 if (PL_opargs[type] & OA_TARGET)
4104 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4105 return CHECKOP(type, padop);
4108 #endif /* !USE_ITHREADS */
4111 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4113 Constructs, checks, and returns an op of any type that involves an
4114 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4115 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4116 reference; calling this function does not transfer ownership of any
4123 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4127 PERL_ARGS_ASSERT_NEWGVOP;
4131 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4133 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4138 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4140 Constructs, checks, and returns an op of any type that involves an
4141 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4142 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4143 must have been allocated using L</PerlMemShared_malloc>; the memory will
4144 be freed when the op is destroyed.
4150 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4155 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4156 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4158 NewOp(1101, pvop, 1, PVOP);
4159 pvop->op_type = (OPCODE)type;
4160 pvop->op_ppaddr = PL_ppaddr[type];
4162 pvop->op_next = (OP*)pvop;
4163 pvop->op_flags = (U8)flags;
4164 if (PL_opargs[type] & OA_RETSCALAR)
4166 if (PL_opargs[type] & OA_TARGET)
4167 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4168 return CHECKOP(type, pvop);
4176 Perl_package(pTHX_ OP *o)
4179 SV *const sv = cSVOPo->op_sv;
4184 PERL_ARGS_ASSERT_PACKAGE;
4186 save_hptr(&PL_curstash);
4187 save_item(PL_curstname);
4189 PL_curstash = gv_stashsv(sv, GV_ADD);
4191 sv_setsv(PL_curstname, sv);
4193 PL_hints |= HINT_BLOCK_SCOPE;
4194 PL_parser->copline = NOLINE;
4195 PL_parser->expect = XSTATE;
4200 if (!PL_madskills) {
4205 pegop = newOP(OP_NULL,0);
4206 op_getmad(o,pegop,'P');
4212 Perl_package_version( pTHX_ OP *v )
4215 U32 savehints = PL_hints;
4216 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4217 PL_hints &= ~HINT_STRICT_VARS;
4218 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4219 PL_hints = savehints;
4228 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4235 OP *pegop = newOP(OP_NULL,0);
4237 SV *use_version = NULL;
4239 PERL_ARGS_ASSERT_UTILIZE;
4241 if (idop->op_type != OP_CONST)
4242 Perl_croak(aTHX_ "Module name must be constant");
4245 op_getmad(idop,pegop,'U');
4250 SV * const vesv = ((SVOP*)version)->op_sv;
4253 op_getmad(version,pegop,'V');
4254 if (!arg && !SvNIOKp(vesv)) {
4261 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4262 Perl_croak(aTHX_ "Version number must be a constant number");
4264 /* Make copy of idop so we don't free it twice */
4265 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4267 /* Fake up a method call to VERSION */
4268 meth = newSVpvs_share("VERSION");
4269 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4270 op_append_elem(OP_LIST,
4271 op_prepend_elem(OP_LIST, pack, list(version)),
4272 newSVOP(OP_METHOD_NAMED, 0, meth)));
4276 /* Fake up an import/unimport */
4277 if (arg && arg->op_type == OP_STUB) {
4279 op_getmad(arg,pegop,'S');
4280 imop = arg; /* no import on explicit () */
4282 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4283 imop = NULL; /* use 5.0; */
4285 use_version = ((SVOP*)idop)->op_sv;
4287 idop->op_private |= OPpCONST_NOVER;
4293 op_getmad(arg,pegop,'A');
4295 /* Make copy of idop so we don't free it twice */
4296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4298 /* Fake up a method call to import/unimport */
4300 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4301 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4302 op_append_elem(OP_LIST,
4303 op_prepend_elem(OP_LIST, pack, list(arg)),
4304 newSVOP(OP_METHOD_NAMED, 0, meth)));
4307 /* Fake up the BEGIN {}, which does its thing immediately. */
4309 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4312 op_append_elem(OP_LINESEQ,
4313 op_append_elem(OP_LINESEQ,
4314 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4315 newSTATEOP(0, NULL, veop)),
4316 newSTATEOP(0, NULL, imop) ));
4319 /* If we request a version >= 5.9.5, load feature.pm with the
4320 * feature bundle that corresponds to the required version. */
4321 use_version = sv_2mortal(new_version(use_version));
4323 if (vcmp(use_version,
4324 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4325 SV *const importsv = vnormal(use_version);
4326 *SvPVX_mutable(importsv) = ':';
4327 ENTER_with_name("load_feature");
4328 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4329 LEAVE_with_name("load_feature");
4331 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4332 if (vcmp(use_version,
4333 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4334 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4338 /* The "did you use incorrect case?" warning used to be here.
4339 * The problem is that on case-insensitive filesystems one
4340 * might get false positives for "use" (and "require"):
4341 * "use Strict" or "require CARP" will work. This causes
4342 * portability problems for the script: in case-strict
4343 * filesystems the script will stop working.
4345 * The "incorrect case" warning checked whether "use Foo"
4346 * imported "Foo" to your namespace, but that is wrong, too:
4347 * there is no requirement nor promise in the language that
4348 * a Foo.pm should or would contain anything in package "Foo".
4350 * There is very little Configure-wise that can be done, either:
4351 * the case-sensitivity of the build filesystem of Perl does not
4352 * help in guessing the case-sensitivity of the runtime environment.
4355 PL_hints |= HINT_BLOCK_SCOPE;
4356 PL_parser->copline = NOLINE;
4357 PL_parser->expect = XSTATE;
4358 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4361 if (!PL_madskills) {
4362 /* FIXME - don't allocate pegop if !PL_madskills */
4371 =head1 Embedding Functions
4373 =for apidoc load_module
4375 Loads the module whose name is pointed to by the string part of name.
4376 Note that the actual module name, not its filename, should be given.
4377 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4378 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4379 (or 0 for no flags). ver, if specified, provides version semantics
4380 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4381 arguments can be used to specify arguments to the module's import()
4382 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4383 terminated with a final NULL pointer. Note that this list can only
4384 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4385 Otherwise at least a single NULL pointer to designate the default
4386 import list is required.
4391 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4395 PERL_ARGS_ASSERT_LOAD_MODULE;
4397 va_start(args, ver);
4398 vload_module(flags, name, ver, &args);
4402 #ifdef PERL_IMPLICIT_CONTEXT
4404 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4408 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4409 va_start(args, ver);
4410 vload_module(flags, name, ver, &args);
4416 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4420 OP * const modname = newSVOP(OP_CONST, 0, name);
4422 PERL_ARGS_ASSERT_VLOAD_MODULE;
4424 modname->op_private |= OPpCONST_BARE;
4426 veop = newSVOP(OP_CONST, 0, ver);
4430 if (flags & PERL_LOADMOD_NOIMPORT) {
4431 imop = sawparens(newNULLLIST());
4433 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4434 imop = va_arg(*args, OP*);
4439 sv = va_arg(*args, SV*);
4441 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4442 sv = va_arg(*args, SV*);
4446 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4447 * that it has a PL_parser to play with while doing that, and also
4448 * that it doesn't mess with any existing parser, by creating a tmp
4449 * new parser with lex_start(). This won't actually be used for much,
4450 * since pp_require() will create another parser for the real work. */
4453 SAVEVPTR(PL_curcop);
4454 lex_start(NULL, NULL, 0);
4455 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4456 veop, modname, imop);
4461 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4467 PERL_ARGS_ASSERT_DOFILE;
4469 if (!force_builtin) {
4470 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4471 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4472 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4473 gv = gvp ? *gvp : NULL;
4477 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4478 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4479 op_append_elem(OP_LIST, term,
4480 scalar(newUNOP(OP_RV2CV, 0,
4481 newGVOP(OP_GV, 0, gv))))));
4484 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4490 =head1 Optree construction
4492 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4494 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4495 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4496 be set automatically, and, shifted up eight bits, the eight bits of
4497 C<op_private>, except that the bit with value 1 or 2 is automatically
4498 set as required. I<listval> and I<subscript> supply the parameters of
4499 the slice; they are consumed by this function and become part of the
4500 constructed op tree.
4506 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4508 return newBINOP(OP_LSLICE, flags,
4509 list(force_list(subscript)),
4510 list(force_list(listval)) );
4514 S_is_list_assignment(pTHX_ register const OP *o)
4522 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4523 o = cUNOPo->op_first;
4525 flags = o->op_flags;
4527 if (type == OP_COND_EXPR) {
4528 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4529 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4534 yyerror("Assignment to both a list and a scalar");
4538 if (type == OP_LIST &&
4539 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4540 o->op_private & OPpLVAL_INTRO)
4543 if (type == OP_LIST || flags & OPf_PARENS ||
4544 type == OP_RV2AV || type == OP_RV2HV ||
4545 type == OP_ASLICE || type == OP_HSLICE)
4548 if (type == OP_PADAV || type == OP_PADHV)
4551 if (type == OP_RV2SV)
4558 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4560 Constructs, checks, and returns an assignment op. I<left> and I<right>
4561 supply the parameters of the assignment; they are consumed by this
4562 function and become part of the constructed op tree.
4564 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4565 a suitable conditional optree is constructed. If I<optype> is the opcode
4566 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4567 performs the binary operation and assigns the result to the left argument.
4568 Either way, if I<optype> is non-zero then I<flags> has no effect.
4570 If I<optype> is zero, then a plain scalar or list assignment is
4571 constructed. Which type of assignment it is is automatically determined.
4572 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4573 will be set automatically, and, shifted up eight bits, the eight bits
4574 of C<op_private>, except that the bit with value 1 or 2 is automatically
4581 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4587 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4588 return newLOGOP(optype, 0,
4589 op_lvalue(scalar(left), optype),
4590 newUNOP(OP_SASSIGN, 0, scalar(right)));
4593 return newBINOP(optype, OPf_STACKED,
4594 op_lvalue(scalar(left), optype), scalar(right));
4598 if (is_list_assignment(left)) {
4599 static const char no_list_state[] = "Initialization of state variables"
4600 " in list context currently forbidden";
4602 bool maybe_common_vars = TRUE;
4605 /* Grandfathering $[ assignment here. Bletch.*/
4606 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4607 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4608 left = op_lvalue(left, OP_AASSIGN);
4611 else if (left->op_type == OP_CONST) {
4612 deprecate("assignment to $[");
4614 /* Result of assignment is always 1 (or we'd be dead already) */
4615 return newSVOP(OP_CONST, 0, newSViv(1));
4617 curop = list(force_list(left));
4618 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4619 o->op_private = (U8)(0 | (flags >> 8));
4621 if ((left->op_type == OP_LIST
4622 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4624 OP* lop = ((LISTOP*)left)->op_first;
4625 maybe_common_vars = FALSE;
4627 if (lop->op_type == OP_PADSV ||
4628 lop->op_type == OP_PADAV ||
4629 lop->op_type == OP_PADHV ||
4630 lop->op_type == OP_PADANY) {
4631 if (!(lop->op_private & OPpLVAL_INTRO))
4632 maybe_common_vars = TRUE;
4634 if (lop->op_private & OPpPAD_STATE) {
4635 if (left->op_private & OPpLVAL_INTRO) {
4636 /* Each variable in state($a, $b, $c) = ... */
4639 /* Each state variable in
4640 (state $a, my $b, our $c, $d, undef) = ... */
4642 yyerror(no_list_state);
4644 /* Each my variable in
4645 (state $a, my $b, our $c, $d, undef) = ... */
4647 } else if (lop->op_type == OP_UNDEF ||
4648 lop->op_type == OP_PUSHMARK) {
4649 /* undef may be interesting in
4650 (state $a, undef, state $c) */
4652 /* Other ops in the list. */
4653 maybe_common_vars = TRUE;
4655 lop = lop->op_sibling;
4658 else if ((left->op_private & OPpLVAL_INTRO)
4659 && ( left->op_type == OP_PADSV
4660 || left->op_type == OP_PADAV
4661 || left->op_type == OP_PADHV
4662 || left->op_type == OP_PADANY))
4664 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4665 if (left->op_private & OPpPAD_STATE) {
4666 /* All single variable list context state assignments, hence
4676 yyerror(no_list_state);
4680 /* PL_generation sorcery:
4681 * an assignment like ($a,$b) = ($c,$d) is easier than
4682 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4683 * To detect whether there are common vars, the global var
4684 * PL_generation is incremented for each assign op we compile.
4685 * Then, while compiling the assign op, we run through all the
4686 * variables on both sides of the assignment, setting a spare slot
4687 * in each of them to PL_generation. If any of them already have
4688 * that value, we know we've got commonality. We could use a
4689 * single bit marker, but then we'd have to make 2 passes, first
4690 * to clear the flag, then to test and set it. To find somewhere
4691 * to store these values, evil chicanery is done with SvUVX().
4694 if (maybe_common_vars) {
4697 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4698 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4699 if (curop->op_type == OP_GV) {
4700 GV *gv = cGVOPx_gv(curop);
4702 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4704 GvASSIGN_GENERATION_set(gv, PL_generation);
4706 else if (curop->op_type == OP_PADSV ||
4707 curop->op_type == OP_PADAV ||
4708 curop->op_type == OP_PADHV ||
4709 curop->op_type == OP_PADANY)
4711 if (PAD_COMPNAME_GEN(curop->op_targ)
4712 == (STRLEN)PL_generation)
4714 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4717 else if (curop->op_type == OP_RV2CV)
4719 else if (curop->op_type == OP_RV2SV ||
4720 curop->op_type == OP_RV2AV ||
4721 curop->op_type == OP_RV2HV ||
4722 curop->op_type == OP_RV2GV) {
4723 if (lastop->op_type != OP_GV) /* funny deref? */
4726 else if (curop->op_type == OP_PUSHRE) {
4728 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4729 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4731 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4733 GvASSIGN_GENERATION_set(gv, PL_generation);
4737 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4740 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4742 GvASSIGN_GENERATION_set(gv, PL_generation);
4752 o->op_private |= OPpASSIGN_COMMON;
4755 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4756 OP* tmpop = ((LISTOP*)right)->op_first;
4757 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4758 PMOP * const pm = (PMOP*)tmpop;
4759 if (left->op_type == OP_RV2AV &&
4760 !(left->op_private & OPpLVAL_INTRO) &&
4761 !(o->op_private & OPpASSIGN_COMMON) )
4763 tmpop = ((UNOP*)left)->op_first;
4764 if (tmpop->op_type == OP_GV
4766 && !pm->op_pmreplrootu.op_pmtargetoff
4768 && !pm->op_pmreplrootu.op_pmtargetgv
4772 pm->op_pmreplrootu.op_pmtargetoff
4773 = cPADOPx(tmpop)->op_padix;
4774 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4776 pm->op_pmreplrootu.op_pmtargetgv
4777 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4778 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4780 pm->op_pmflags |= PMf_ONCE;
4781 tmpop = cUNOPo->op_first; /* to list (nulled) */
4782 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4783 tmpop->op_sibling = NULL; /* don't free split */
4784 right->op_next = tmpop->op_next; /* fix starting loc */
4785 op_free(o); /* blow off assign */
4786 right->op_flags &= ~OPf_WANT;
4787 /* "I don't know and I don't care." */
4792 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4793 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4795 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4796 if (SvIOK(sv) && SvIVX(sv) == 0)
4797 sv_setiv(sv, PL_modcount+1);
4805 right = newOP(OP_UNDEF, 0);
4806 if (right->op_type == OP_READLINE) {
4807 right->op_flags |= OPf_STACKED;
4808 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4812 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4813 o = newBINOP(OP_SASSIGN, flags,
4814 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4818 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4819 deprecate("assignment to $[");
4821 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4822 o->op_private |= OPpCONST_ARYBASE;
4830 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4832 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4833 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4834 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4835 If I<label> is non-null, it supplies the name of a label to attach to
4836 the state op; this function takes ownership of the memory pointed at by
4837 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4840 If I<o> is null, the state op is returned. Otherwise the state op is
4841 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4842 is consumed by this function and becomes part of the returned op tree.
4848 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4851 const U32 seq = intro_my();
4854 NewOp(1101, cop, 1, COP);
4855 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4856 cop->op_type = OP_DBSTATE;
4857 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4860 cop->op_type = OP_NEXTSTATE;
4861 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4863 cop->op_flags = (U8)flags;
4864 CopHINTS_set(cop, PL_hints);
4866 cop->op_private |= NATIVE_HINTS;
4868 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4869 cop->op_next = (OP*)cop;
4872 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4873 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4875 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4876 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4878 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4880 PL_hints |= HINT_BLOCK_SCOPE;
4881 /* It seems that we need to defer freeing this pointer, as other parts
4882 of the grammar end up wanting to copy it after this op has been
4887 if (PL_parser && PL_parser->copline == NOLINE)
4888 CopLINE_set(cop, CopLINE(PL_curcop));
4890 CopLINE_set(cop, PL_parser->copline);
4892 PL_parser->copline = NOLINE;
4895 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4897 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4899 CopSTASH_set(cop, PL_curstash);
4901 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4902 /* this line can have a breakpoint - store the cop in IV */
4903 AV *av = CopFILEAVx(PL_curcop);
4905 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4906 if (svp && *svp != &PL_sv_undef ) {
4907 (void)SvIOK_on(*svp);
4908 SvIV_set(*svp, PTR2IV(cop));
4913 if (flags & OPf_SPECIAL)
4915 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4919 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4921 Constructs, checks, and returns a logical (flow control) op. I<type>
4922 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4923 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4924 the eight bits of C<op_private>, except that the bit with value 1 is
4925 automatically set. I<first> supplies the expression controlling the
4926 flow, and I<other> supplies the side (alternate) chain of ops; they are
4927 consumed by this function and become part of the constructed op tree.
4933 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4937 PERL_ARGS_ASSERT_NEWLOGOP;
4939 return new_logop(type, flags, &first, &other);
4943 S_search_const(pTHX_ OP *o)
4945 PERL_ARGS_ASSERT_SEARCH_CONST;
4947 switch (o->op_type) {
4951 if (o->op_flags & OPf_KIDS)
4952 return search_const(cUNOPo->op_first);
4959 if (!(o->op_flags & OPf_KIDS))
4961 kid = cLISTOPo->op_first;
4963 switch (kid->op_type) {
4967 kid = kid->op_sibling;
4970 if (kid != cLISTOPo->op_last)
4976 kid = cLISTOPo->op_last;
4978 return search_const(kid);
4986 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4994 int prepend_not = 0;
4996 PERL_ARGS_ASSERT_NEW_LOGOP;
5001 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5002 return newBINOP(type, flags, scalar(first), scalar(other));
5004 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5006 scalarboolean(first);
5007 /* optimize AND and OR ops that have NOTs as children */
5008 if (first->op_type == OP_NOT
5009 && (first->op_flags & OPf_KIDS)
5010 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5011 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5013 if (type == OP_AND || type == OP_OR) {
5019 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5021 prepend_not = 1; /* prepend a NOT op later */
5025 /* search for a constant op that could let us fold the test */
5026 if ((cstop = search_const(first))) {
5027 if (cstop->op_private & OPpCONST_STRICT)
5028 no_bareword_allowed(cstop);
5029 else if ((cstop->op_private & OPpCONST_BARE))
5030 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5031 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5032 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5033 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5035 if (other->op_type == OP_CONST)
5036 other->op_private |= OPpCONST_SHORTCIRCUIT;
5038 OP *newop = newUNOP(OP_NULL, 0, other);
5039 op_getmad(first, newop, '1');
5040 newop->op_targ = type; /* set "was" field */
5044 if (other->op_type == OP_LEAVE)
5045 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5046 else if (other->op_type == OP_MATCH
5047 || other->op_type == OP_SUBST
5048 || other->op_type == OP_TRANSR
5049 || other->op_type == OP_TRANS)
5050 /* Mark the op as being unbindable with =~ */
5051 other->op_flags |= OPf_SPECIAL;
5055 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5056 const OP *o2 = other;
5057 if ( ! (o2->op_type == OP_LIST
5058 && (( o2 = cUNOPx(o2)->op_first))
5059 && o2->op_type == OP_PUSHMARK
5060 && (( o2 = o2->op_sibling)) )
5063 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5064 || o2->op_type == OP_PADHV)
5065 && o2->op_private & OPpLVAL_INTRO
5066 && !(o2->op_private & OPpPAD_STATE))
5068 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5069 "Deprecated use of my() in false conditional");
5073 if (first->op_type == OP_CONST)
5074 first->op_private |= OPpCONST_SHORTCIRCUIT;
5076 first = newUNOP(OP_NULL, 0, first);
5077 op_getmad(other, first, '2');
5078 first->op_targ = type; /* set "was" field */
5085 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5086 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5088 const OP * const k1 = ((UNOP*)first)->op_first;
5089 const OP * const k2 = k1->op_sibling;
5091 switch (first->op_type)
5094 if (k2 && k2->op_type == OP_READLINE
5095 && (k2->op_flags & OPf_STACKED)
5096 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5098 warnop = k2->op_type;
5103 if (k1->op_type == OP_READDIR
5104 || k1->op_type == OP_GLOB
5105 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5106 || k1->op_type == OP_EACH)
5108 warnop = ((k1->op_type == OP_NULL)
5109 ? (OPCODE)k1->op_targ : k1->op_type);
5114 const line_t oldline = CopLINE(PL_curcop);
5115 CopLINE_set(PL_curcop, PL_parser->copline);
5116 Perl_warner(aTHX_ packWARN(WARN_MISC),
5117 "Value of %s%s can be \"0\"; test with defined()",
5119 ((warnop == OP_READLINE || warnop == OP_GLOB)
5120 ? " construct" : "() operator"));
5121 CopLINE_set(PL_curcop, oldline);
5128 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5129 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5131 NewOp(1101, logop, 1, LOGOP);
5133 logop->op_type = (OPCODE)type;
5134 logop->op_ppaddr = PL_ppaddr[type];
5135 logop->op_first = first;
5136 logop->op_flags = (U8)(flags | OPf_KIDS);
5137 logop->op_other = LINKLIST(other);
5138 logop->op_private = (U8)(1 | (flags >> 8));
5140 /* establish postfix order */
5141 logop->op_next = LINKLIST(first);
5142 first->op_next = (OP*)logop;
5143 first->op_sibling = other;
5145 CHECKOP(type,logop);
5147 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5154 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5156 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5157 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5158 will be set automatically, and, shifted up eight bits, the eight bits of
5159 C<op_private>, except that the bit with value 1 is automatically set.
5160 I<first> supplies the expression selecting between the two branches,
5161 and I<trueop> and I<falseop> supply the branches; they are consumed by
5162 this function and become part of the constructed op tree.
5168 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5176 PERL_ARGS_ASSERT_NEWCONDOP;
5179 return newLOGOP(OP_AND, 0, first, trueop);
5181 return newLOGOP(OP_OR, 0, first, falseop);
5183 scalarboolean(first);
5184 if ((cstop = search_const(first))) {
5185 /* Left or right arm of the conditional? */
5186 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5187 OP *live = left ? trueop : falseop;
5188 OP *const dead = left ? falseop : trueop;
5189 if (cstop->op_private & OPpCONST_BARE &&
5190 cstop->op_private & OPpCONST_STRICT) {
5191 no_bareword_allowed(cstop);
5194 /* This is all dead code when PERL_MAD is not defined. */
5195 live = newUNOP(OP_NULL, 0, live);
5196 op_getmad(first, live, 'C');
5197 op_getmad(dead, live, left ? 'e' : 't');
5202 if (live->op_type == OP_LEAVE)
5203 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5204 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5205 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5206 /* Mark the op as being unbindable with =~ */
5207 live->op_flags |= OPf_SPECIAL;
5210 NewOp(1101, logop, 1, LOGOP);
5211 logop->op_type = OP_COND_EXPR;
5212 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5213 logop->op_first = first;
5214 logop->op_flags = (U8)(flags | OPf_KIDS);
5215 logop->op_private = (U8)(1 | (flags >> 8));
5216 logop->op_other = LINKLIST(trueop);
5217 logop->op_next = LINKLIST(falseop);
5219 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5222 /* establish postfix order */
5223 start = LINKLIST(first);
5224 first->op_next = (OP*)logop;
5226 first->op_sibling = trueop;
5227 trueop->op_sibling = falseop;
5228 o = newUNOP(OP_NULL, 0, (OP*)logop);
5230 trueop->op_next = falseop->op_next = o;
5237 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5239 Constructs and returns a C<range> op, with subordinate C<flip> and
5240 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5241 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5242 for both the C<flip> and C<range> ops, except that the bit with value
5243 1 is automatically set. I<left> and I<right> supply the expressions
5244 controlling the endpoints of the range; they are consumed by this function
5245 and become part of the constructed op tree.
5251 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5260 PERL_ARGS_ASSERT_NEWRANGE;
5262 NewOp(1101, range, 1, LOGOP);
5264 range->op_type = OP_RANGE;
5265 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5266 range->op_first = left;
5267 range->op_flags = OPf_KIDS;
5268 leftstart = LINKLIST(left);
5269 range->op_other = LINKLIST(right);
5270 range->op_private = (U8)(1 | (flags >> 8));
5272 left->op_sibling = right;
5274 range->op_next = (OP*)range;
5275 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5276 flop = newUNOP(OP_FLOP, 0, flip);
5277 o = newUNOP(OP_NULL, 0, flop);
5279 range->op_next = leftstart;
5281 left->op_next = flip;
5282 right->op_next = flop;
5284 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5285 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5286 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5287 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5289 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5290 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5293 if (!flip->op_private || !flop->op_private)
5294 LINKLIST(o); /* blow off optimizer unless constant */
5300 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5302 Constructs, checks, and returns an op tree expressing a loop. This is
5303 only a loop in the control flow through the op tree; it does not have
5304 the heavyweight loop structure that allows exiting the loop by C<last>
5305 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5306 top-level op, except that some bits will be set automatically as required.
5307 I<expr> supplies the expression controlling loop iteration, and I<block>
5308 supplies the body of the loop; they are consumed by this function and
5309 become part of the constructed op tree. I<debuggable> is currently
5310 unused and should always be 1.
5316 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5321 const bool once = block && block->op_flags & OPf_SPECIAL &&
5322 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5324 PERL_UNUSED_ARG(debuggable);
5327 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5328 return block; /* do {} while 0 does once */
5329 if (expr->op_type == OP_READLINE
5330 || expr->op_type == OP_READDIR
5331 || expr->op_type == OP_GLOB
5332 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5333 expr = newUNOP(OP_DEFINED, 0,
5334 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5335 } else if (expr->op_flags & OPf_KIDS) {
5336 const OP * const k1 = ((UNOP*)expr)->op_first;
5337 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5338 switch (expr->op_type) {
5340 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5341 && (k2->op_flags & OPf_STACKED)
5342 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5343 expr = newUNOP(OP_DEFINED, 0, expr);
5347 if (k1 && (k1->op_type == OP_READDIR
5348 || k1->op_type == OP_GLOB
5349 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5350 || k1->op_type == OP_EACH))
5351 expr = newUNOP(OP_DEFINED, 0, expr);
5357 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5358 * op, in listop. This is wrong. [perl #27024] */
5360 block = newOP(OP_NULL, 0);
5361 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5362 o = new_logop(OP_AND, 0, &expr, &listop);
5365 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5367 if (once && o != listop)
5368 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5371 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5373 o->op_flags |= flags;
5375 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5380 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5382 Constructs, checks, and returns an op tree expressing a C<while> loop.
5383 This is a heavyweight loop, with structure that allows exiting the loop
5384 by C<last> and suchlike.
5386 I<loop> is an optional preconstructed C<enterloop> op to use in the
5387 loop; if it is null then a suitable op will be constructed automatically.
5388 I<expr> supplies the loop's controlling expression. I<block> supplies the
5389 main body of the loop, and I<cont> optionally supplies a C<continue> block
5390 that operates as a second half of the body. All of these optree inputs
5391 are consumed by this function and become part of the constructed op tree.
5393 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5394 op and, shifted up eight bits, the eight bits of C<op_private> for
5395 the C<leaveloop> op, except that (in both cases) some bits will be set
5396 automatically. I<debuggable> is currently unused and should always be 1.
5397 I<has_my> can be supplied as true to force the
5398 loop body to be enclosed in its own scope.
5404 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5405 OP *expr, OP *block, OP *cont, I32 has_my)
5414 PERL_UNUSED_ARG(debuggable);
5417 if (expr->op_type == OP_READLINE
5418 || expr->op_type == OP_READDIR
5419 || expr->op_type == OP_GLOB
5420 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5421 expr = newUNOP(OP_DEFINED, 0,
5422 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5423 } else if (expr->op_flags & OPf_KIDS) {
5424 const OP * const k1 = ((UNOP*)expr)->op_first;
5425 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5426 switch (expr->op_type) {
5428 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5429 && (k2->op_flags & OPf_STACKED)
5430 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5431 expr = newUNOP(OP_DEFINED, 0, expr);
5435 if (k1 && (k1->op_type == OP_READDIR
5436 || k1->op_type == OP_GLOB
5437 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5438 || k1->op_type == OP_EACH))
5439 expr = newUNOP(OP_DEFINED, 0, expr);
5446 block = newOP(OP_NULL, 0);
5447 else if (cont || has_my) {
5448 block = op_scope(block);
5452 next = LINKLIST(cont);
5455 OP * const unstack = newOP(OP_UNSTACK, 0);
5458 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5462 listop = op_append_list(OP_LINESEQ, block, cont);
5464 redo = LINKLIST(listop);
5468 o = new_logop(OP_AND, 0, &expr, &listop);
5469 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5470 op_free(expr); /* oops, it's a while (0) */
5472 return NULL; /* listop already freed by new_logop */
5475 ((LISTOP*)listop)->op_last->op_next =
5476 (o == listop ? redo : LINKLIST(o));
5482 NewOp(1101,loop,1,LOOP);
5483 loop->op_type = OP_ENTERLOOP;
5484 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5485 loop->op_private = 0;
5486 loop->op_next = (OP*)loop;
5489 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5491 loop->op_redoop = redo;
5492 loop->op_lastop = o;
5493 o->op_private |= loopflags;
5496 loop->op_nextop = next;
5498 loop->op_nextop = o;
5500 o->op_flags |= flags;
5501 o->op_private |= (flags >> 8);
5506 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5508 Constructs, checks, and returns an op tree expressing a C<foreach>
5509 loop (iteration through a list of values). This is a heavyweight loop,
5510 with structure that allows exiting the loop by C<last> and suchlike.
5512 I<sv> optionally supplies the variable that will be aliased to each
5513 item in turn; if null, it defaults to C<$_> (either lexical or global).
5514 I<expr> supplies the list of values to iterate over. I<block> supplies
5515 the main body of the loop, and I<cont> optionally supplies a C<continue>
5516 block that operates as a second half of the body. All of these optree
5517 inputs are consumed by this function and become part of the constructed
5520 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5521 op and, shifted up eight bits, the eight bits of C<op_private> for
5522 the C<leaveloop> op, except that (in both cases) some bits will be set
5529 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5534 PADOFFSET padoff = 0;
5539 PERL_ARGS_ASSERT_NEWFOROP;
5542 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5543 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5544 sv->op_type = OP_RV2GV;
5545 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5547 /* The op_type check is needed to prevent a possible segfault
5548 * if the loop variable is undeclared and 'strict vars' is in
5549 * effect. This is illegal but is nonetheless parsed, so we
5550 * may reach this point with an OP_CONST where we're expecting
5553 if (cUNOPx(sv)->op_first->op_type == OP_GV
5554 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5555 iterpflags |= OPpITER_DEF;
5557 else if (sv->op_type == OP_PADSV) { /* private variable */
5558 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5559 padoff = sv->op_targ;
5569 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5571 SV *const namesv = PAD_COMPNAME_SV(padoff);
5573 const char *const name = SvPV_const(namesv, len);
5575 if (len == 2 && name[0] == '$' && name[1] == '_')
5576 iterpflags |= OPpITER_DEF;
5580 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5581 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5582 sv = newGVOP(OP_GV, 0, PL_defgv);
5587 iterpflags |= OPpITER_DEF;
5589 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5590 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5591 iterflags |= OPf_STACKED;
5593 else if (expr->op_type == OP_NULL &&
5594 (expr->op_flags & OPf_KIDS) &&
5595 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5597 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5598 * set the STACKED flag to indicate that these values are to be
5599 * treated as min/max values by 'pp_iterinit'.
5601 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5602 LOGOP* const range = (LOGOP*) flip->op_first;
5603 OP* const left = range->op_first;
5604 OP* const right = left->op_sibling;
5607 range->op_flags &= ~OPf_KIDS;
5608 range->op_first = NULL;
5610 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5611 listop->op_first->op_next = range->op_next;
5612 left->op_next = range->op_other;
5613 right->op_next = (OP*)listop;
5614 listop->op_next = listop->op_first;
5617 op_getmad(expr,(OP*)listop,'O');
5621 expr = (OP*)(listop);
5623 iterflags |= OPf_STACKED;
5626 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5629 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5630 op_append_elem(OP_LIST, expr, scalar(sv))));
5631 assert(!loop->op_next);
5632 /* for my $x () sets OPpLVAL_INTRO;
5633 * for our $x () sets OPpOUR_INTRO */
5634 loop->op_private = (U8)iterpflags;
5635 #ifdef PL_OP_SLAB_ALLOC
5638 NewOp(1234,tmp,1,LOOP);
5639 Copy(loop,tmp,1,LISTOP);
5640 S_op_destroy(aTHX_ (OP*)loop);
5644 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5646 loop->op_targ = padoff;
5647 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5649 op_getmad(madsv, (OP*)loop, 'v');
5654 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5656 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5657 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5658 determining the target of the op; it is consumed by this function and
5659 become part of the constructed op tree.
5665 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5670 PERL_ARGS_ASSERT_NEWLOOPEX;
5672 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5674 if (type != OP_GOTO || label->op_type == OP_CONST) {
5675 /* "last()" means "last" */
5676 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5677 o = newOP(type, OPf_SPECIAL);
5679 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5680 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5684 op_getmad(label,o,'L');
5690 /* Check whether it's going to be a goto &function */
5691 if (label->op_type == OP_ENTERSUB
5692 && !(label->op_flags & OPf_STACKED))
5693 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5694 o = newUNOP(type, OPf_STACKED, label);
5696 PL_hints |= HINT_BLOCK_SCOPE;
5700 /* if the condition is a literal array or hash
5701 (or @{ ... } etc), make a reference to it.
5704 S_ref_array_or_hash(pTHX_ OP *cond)
5707 && (cond->op_type == OP_RV2AV
5708 || cond->op_type == OP_PADAV
5709 || cond->op_type == OP_RV2HV
5710 || cond->op_type == OP_PADHV))
5712 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5715 && (cond->op_type == OP_ASLICE
5716 || cond->op_type == OP_HSLICE)) {
5718 /* anonlist now needs a list from this op, was previously used in
5720 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5721 cond->op_flags |= OPf_WANT_LIST;
5723 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5730 /* These construct the optree fragments representing given()
5733 entergiven and enterwhen are LOGOPs; the op_other pointer
5734 points up to the associated leave op. We need this so we
5735 can put it in the context and make break/continue work.
5736 (Also, of course, pp_enterwhen will jump straight to
5737 op_other if the match fails.)
5741 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5742 I32 enter_opcode, I32 leave_opcode,
5743 PADOFFSET entertarg)
5749 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5751 NewOp(1101, enterop, 1, LOGOP);
5752 enterop->op_type = (Optype)enter_opcode;
5753 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5754 enterop->op_flags = (U8) OPf_KIDS;
5755 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5756 enterop->op_private = 0;
5758 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5761 enterop->op_first = scalar(cond);
5762 cond->op_sibling = block;
5764 o->op_next = LINKLIST(cond);
5765 cond->op_next = (OP *) enterop;
5768 /* This is a default {} block */
5769 enterop->op_first = block;
5770 enterop->op_flags |= OPf_SPECIAL;
5772 o->op_next = (OP *) enterop;
5775 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5776 entergiven and enterwhen both
5779 enterop->op_next = LINKLIST(block);
5780 block->op_next = enterop->op_other = o;
5785 /* Does this look like a boolean operation? For these purposes
5786 a boolean operation is:
5787 - a subroutine call [*]
5788 - a logical connective
5789 - a comparison operator
5790 - a filetest operator, with the exception of -s -M -A -C
5791 - defined(), exists() or eof()
5792 - /$re/ or $foo =~ /$re/
5794 [*] possibly surprising
5797 S_looks_like_bool(pTHX_ const OP *o)
5801 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5803 switch(o->op_type) {
5806 return looks_like_bool(cLOGOPo->op_first);
5810 looks_like_bool(cLOGOPo->op_first)
5811 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5816 o->op_flags & OPf_KIDS
5817 && looks_like_bool(cUNOPo->op_first));
5821 case OP_NOT: case OP_XOR:
5823 case OP_EQ: case OP_NE: case OP_LT:
5824 case OP_GT: case OP_LE: case OP_GE:
5826 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5827 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5829 case OP_SEQ: case OP_SNE: case OP_SLT:
5830 case OP_SGT: case OP_SLE: case OP_SGE:
5834 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5835 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5836 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5837 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5838 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5839 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5840 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5841 case OP_FTTEXT: case OP_FTBINARY:
5843 case OP_DEFINED: case OP_EXISTS:
5844 case OP_MATCH: case OP_EOF:
5851 /* Detect comparisons that have been optimized away */
5852 if (cSVOPo->op_sv == &PL_sv_yes
5853 || cSVOPo->op_sv == &PL_sv_no)
5866 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5868 Constructs, checks, and returns an op tree expressing a C<given> block.
5869 I<cond> supplies the expression that will be locally assigned to a lexical
5870 variable, and I<block> supplies the body of the C<given> construct; they
5871 are consumed by this function and become part of the constructed op tree.
5872 I<defsv_off> is the pad offset of the scalar lexical variable that will
5879 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5882 PERL_ARGS_ASSERT_NEWGIVENOP;
5883 return newGIVWHENOP(
5884 ref_array_or_hash(cond),
5886 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5891 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5893 Constructs, checks, and returns an op tree expressing a C<when> block.
5894 I<cond> supplies the test expression, and I<block> supplies the block
5895 that will be executed if the test evaluates to true; they are consumed
5896 by this function and become part of the constructed op tree. I<cond>
5897 will be interpreted DWIMically, often as a comparison against C<$_>,
5898 and may be null to generate a C<default> block.
5904 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5906 const bool cond_llb = (!cond || looks_like_bool(cond));
5909 PERL_ARGS_ASSERT_NEWWHENOP;
5914 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5916 scalar(ref_array_or_hash(cond)));
5919 return newGIVWHENOP(
5921 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5922 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5926 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5929 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5931 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5932 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5933 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5934 || (p && (len != SvCUR(cv) /* Not the same length. */
5935 || memNE(p, SvPVX_const(cv), len))))
5936 && ckWARN_d(WARN_PROTOTYPE)) {
5937 SV* const msg = sv_newmortal();
5941 gv_efullname3(name = sv_newmortal(), gv, NULL);
5942 sv_setpvs(msg, "Prototype mismatch:");
5944 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5946 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5948 sv_catpvs(msg, ": none");
5949 sv_catpvs(msg, " vs ");
5951 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5953 sv_catpvs(msg, "none");
5954 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5958 static void const_sv_xsub(pTHX_ CV* cv);
5962 =head1 Optree Manipulation Functions
5964 =for apidoc cv_const_sv
5966 If C<cv> is a constant sub eligible for inlining. returns the constant
5967 value returned by the sub. Otherwise, returns NULL.
5969 Constant subs can be created with C<newCONSTSUB> or as described in
5970 L<perlsub/"Constant Functions">.
5975 Perl_cv_const_sv(pTHX_ const CV *const cv)
5977 PERL_UNUSED_CONTEXT;
5980 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5982 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5985 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5986 * Can be called in 3 ways:
5989 * look for a single OP_CONST with attached value: return the value
5991 * cv && CvCLONE(cv) && !CvCONST(cv)
5993 * examine the clone prototype, and if contains only a single
5994 * OP_CONST referencing a pad const, or a single PADSV referencing
5995 * an outer lexical, return a non-zero value to indicate the CV is
5996 * a candidate for "constizing" at clone time
6000 * We have just cloned an anon prototype that was marked as a const
6001 * candidiate. Try to grab the current value, and in the case of
6002 * PADSV, ignore it if it has multiple references. Return the value.
6006 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6017 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6018 o = cLISTOPo->op_first->op_sibling;
6020 for (; o; o = o->op_next) {
6021 const OPCODE type = o->op_type;
6023 if (sv && o->op_next == o)
6025 if (o->op_next != o) {
6026 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6028 if (type == OP_DBSTATE)
6031 if (type == OP_LEAVESUB || type == OP_RETURN)
6035 if (type == OP_CONST && cSVOPo->op_sv)
6037 else if (cv && type == OP_CONST) {
6038 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6042 else if (cv && type == OP_PADSV) {
6043 if (CvCONST(cv)) { /* newly cloned anon */
6044 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6045 /* the candidate should have 1 ref from this pad and 1 ref
6046 * from the parent */
6047 if (!sv || SvREFCNT(sv) != 2)
6054 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6055 sv = &PL_sv_undef; /* an arbitrary non-null value */
6070 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6073 /* This would be the return value, but the return cannot be reached. */
6074 OP* pegop = newOP(OP_NULL, 0);
6077 PERL_UNUSED_ARG(floor);
6087 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6089 NORETURN_FUNCTION_END;
6094 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6099 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6100 register CV *cv = NULL;
6102 /* If the subroutine has no body, no attributes, and no builtin attributes
6103 then it's just a sub declaration, and we may be able to get away with
6104 storing with a placeholder scalar in the symbol table, rather than a
6105 full GV and CV. If anything is present then it will take a full CV to
6107 const I32 gv_fetch_flags
6108 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6110 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6111 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6115 assert(proto->op_type == OP_CONST);
6116 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6122 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6124 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6125 SV * const sv = sv_newmortal();
6126 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6127 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6128 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6129 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6131 } else if (PL_curstash) {
6132 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6135 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6139 if (!PL_madskills) {
6148 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6149 maximum a prototype before. */
6150 if (SvTYPE(gv) > SVt_NULL) {
6151 if (!SvPOK((const SV *)gv)
6152 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6154 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6156 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6159 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6161 sv_setiv(MUTABLE_SV(gv), -1);
6163 SvREFCNT_dec(PL_compcv);
6164 cv = PL_compcv = NULL;
6168 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6170 if (!block || !ps || *ps || attrs
6171 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6173 || block->op_type == OP_NULL
6178 const_sv = op_const_sv(block, NULL);
6181 const bool exists = CvROOT(cv) || CvXSUB(cv);
6183 /* if the subroutine doesn't exist and wasn't pre-declared
6184 * with a prototype, assume it will be AUTOLOADed,
6185 * skipping the prototype check
6187 if (exists || SvPOK(cv))
6188 cv_ckproto_len(cv, gv, ps, ps_len);
6189 /* already defined (or promised)? */
6190 if (exists || GvASSUMECV(gv)) {
6193 || block->op_type == OP_NULL
6196 if (CvFLAGS(PL_compcv)) {
6197 /* might have had built-in attrs applied */
6198 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6199 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6200 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6202 /* just a "sub foo;" when &foo is already defined */
6203 SAVEFREESV(PL_compcv);
6208 && block->op_type != OP_NULL
6211 if (ckWARN(WARN_REDEFINE)
6213 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6215 const line_t oldline = CopLINE(PL_curcop);
6216 if (PL_parser && PL_parser->copline != NOLINE)
6217 CopLINE_set(PL_curcop, PL_parser->copline);
6218 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6219 CvCONST(cv) ? "Constant subroutine %s redefined"
6220 : "Subroutine %s redefined", name);
6221 CopLINE_set(PL_curcop, oldline);
6224 if (!PL_minus_c) /* keep old one around for madskills */
6227 /* (PL_madskills unset in used file.) */
6235 SvREFCNT_inc_simple_void_NN(const_sv);
6237 assert(!CvROOT(cv) && !CvCONST(cv));
6238 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6239 CvXSUBANY(cv).any_ptr = const_sv;
6240 CvXSUB(cv) = const_sv_xsub;
6246 cv = newCONSTSUB(NULL, name, const_sv);
6248 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6249 (CvGV(cv) && GvSTASH(CvGV(cv)))
6258 SvREFCNT_dec(PL_compcv);
6262 if (cv) { /* must reuse cv if autoloaded */
6263 /* transfer PL_compcv to cv */
6266 && block->op_type != OP_NULL
6269 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6270 AV *const temp_av = CvPADLIST(cv);
6271 CV *const temp_cv = CvOUTSIDE(cv);
6273 assert(!CvWEAKOUTSIDE(cv));
6274 assert(!CvCVGV_RC(cv));
6275 assert(CvGV(cv) == gv);
6278 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6279 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6280 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6281 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6282 CvOUTSIDE(PL_compcv) = temp_cv;
6283 CvPADLIST(PL_compcv) = temp_av;
6286 if (CvFILE(cv) && !CvISXSUB(cv)) {
6287 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6288 Safefree(CvFILE(cv));
6291 CvFILE_set_from_cop(cv, PL_curcop);
6292 CvSTASH_set(cv, PL_curstash);
6294 /* inner references to PL_compcv must be fixed up ... */
6295 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6296 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6297 ++PL_sub_generation;
6300 /* Might have had built-in attributes applied -- propagate them. */
6301 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6303 /* ... before we throw it away */
6304 SvREFCNT_dec(PL_compcv);
6312 if (strEQ(name, "import")) {
6313 PL_formfeed = MUTABLE_SV(cv);
6314 /* diag_listed_as: SKIPME */
6315 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6319 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6324 CvFILE_set_from_cop(cv, PL_curcop);
6325 CvSTASH_set(cv, PL_curstash);
6328 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6329 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6330 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6334 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6336 if (PL_parser && PL_parser->error_count) {
6340 const char *s = strrchr(name, ':');
6342 if (strEQ(s, "BEGIN")) {
6343 const char not_safe[] =
6344 "BEGIN not safe after errors--compilation aborted";
6345 if (PL_in_eval & EVAL_KEEPERR)
6346 Perl_croak(aTHX_ not_safe);
6348 /* force display of errors found but not reported */
6349 sv_catpv(ERRSV, not_safe);
6350 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6359 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6360 the debugger could be able to set a breakpoint in, so signal to
6361 pp_entereval that it should not throw away any saved lines at scope
6364 PL_breakable_sub_gen++;
6366 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6367 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6368 block->op_attached = 1;
6371 /* This makes sub {}; work as expected. */
6372 if (block->op_type == OP_STUB) {
6373 OP* const newblock = newSTATEOP(0, NULL, 0);
6375 op_getmad(block,newblock,'B');
6382 block->op_attached = 1;
6383 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6385 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6386 OpREFCNT_set(CvROOT(cv), 1);
6387 CvSTART(cv) = LINKLIST(CvROOT(cv));
6388 CvROOT(cv)->op_next = 0;
6389 CALL_PEEP(CvSTART(cv));
6391 /* now that optimizer has done its work, adjust pad values */
6393 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6396 assert(!CvCONST(cv));
6397 if (ps && !*ps && op_const_sv(block, cv))
6402 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6403 SV * const tmpstr = sv_newmortal();
6404 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6405 GV_ADDMULTI, SVt_PVHV);
6407 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6410 (long)CopLINE(PL_curcop));
6411 gv_efullname3(tmpstr, gv, NULL);
6412 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6413 SvCUR(tmpstr), sv, 0);
6414 hv = GvHVn(db_postponed);
6415 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6416 CV * const pcv = GvCV(db_postponed);
6422 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6427 if (name && ! (PL_parser && PL_parser->error_count))
6428 process_special_blocks(name, gv, cv);
6433 PL_parser->copline = NOLINE;
6439 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6442 const char *const colon = strrchr(fullname,':');
6443 const char *const name = colon ? colon + 1 : fullname;
6445 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6448 if (strEQ(name, "BEGIN")) {
6449 const I32 oldscope = PL_scopestack_ix;
6451 SAVECOPFILE(&PL_compiling);
6452 SAVECOPLINE(&PL_compiling);
6454 DEBUG_x( dump_sub(gv) );
6455 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6456 GvCV(gv) = 0; /* cv has been hijacked */
6457 call_list(oldscope, PL_beginav);
6459 PL_curcop = &PL_compiling;
6460 CopHINTS_set(&PL_compiling, PL_hints);
6467 if strEQ(name, "END") {
6468 DEBUG_x( dump_sub(gv) );
6469 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6472 } else if (*name == 'U') {
6473 if (strEQ(name, "UNITCHECK")) {
6474 /* It's never too late to run a unitcheck block */
6475 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6479 } else if (*name == 'C') {
6480 if (strEQ(name, "CHECK")) {
6482 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6483 "Too late to run CHECK block");
6484 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6488 } else if (*name == 'I') {
6489 if (strEQ(name, "INIT")) {
6491 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6492 "Too late to run INIT block");
6493 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6499 DEBUG_x( dump_sub(gv) );
6500 GvCV(gv) = 0; /* cv has been hijacked */
6505 =for apidoc newCONSTSUB
6507 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6508 eligible for inlining at compile-time.
6510 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6511 which won't be called if used as a destructor, but will suppress the overhead
6512 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6519 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6524 const char *const file = CopFILE(PL_curcop);
6526 SV *const temp_sv = CopFILESV(PL_curcop);
6527 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6532 if (IN_PERL_RUNTIME) {
6533 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6534 * an op shared between threads. Use a non-shared COP for our
6536 SAVEVPTR(PL_curcop);
6537 PL_curcop = &PL_compiling;
6539 SAVECOPLINE(PL_curcop);
6540 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6543 PL_hints &= ~HINT_BLOCK_SCOPE;
6546 SAVESPTR(PL_curstash);
6547 SAVECOPSTASH(PL_curcop);
6548 PL_curstash = stash;
6549 CopSTASH_set(PL_curcop,stash);
6552 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6553 and so doesn't get free()d. (It's expected to be from the C pre-
6554 processor __FILE__ directive). But we need a dynamically allocated one,
6555 and we need it to get freed. */
6556 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6557 XS_DYNAMIC_FILENAME);
6558 CvXSUBANY(cv).any_ptr = sv;
6563 CopSTASH_free(PL_curcop);
6571 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6572 const char *const filename, const char *const proto,
6575 CV *cv = newXS(name, subaddr, filename);
6577 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6579 if (flags & XS_DYNAMIC_FILENAME) {
6580 /* We need to "make arrangements" (ie cheat) to ensure that the
6581 filename lasts as long as the PVCV we just created, but also doesn't
6583 STRLEN filename_len = strlen(filename);
6584 STRLEN proto_and_file_len = filename_len;
6585 char *proto_and_file;
6589 proto_len = strlen(proto);
6590 proto_and_file_len += proto_len;
6592 Newx(proto_and_file, proto_and_file_len + 1, char);
6593 Copy(proto, proto_and_file, proto_len, char);
6594 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6597 proto_and_file = savepvn(filename, filename_len);
6600 /* This gets free()d. :-) */
6601 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6602 SV_HAS_TRAILING_NUL);
6604 /* This gives us the correct prototype, rather than one with the
6605 file name appended. */
6606 SvCUR_set(cv, proto_len);
6610 CvFILE(cv) = proto_and_file + proto_len;
6612 sv_setpv(MUTABLE_SV(cv), proto);
6618 =for apidoc U||newXS
6620 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6621 static storage, as it is used directly as CvFILE(), without a copy being made.
6627 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6630 GV * const gv = gv_fetchpv(name ? name :
6631 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6632 GV_ADDMULTI, SVt_PVCV);
6635 PERL_ARGS_ASSERT_NEWXS;
6638 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6640 if ((cv = (name ? GvCV(gv) : NULL))) {
6642 /* just a cached method */
6646 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6647 /* already defined (or promised) */
6648 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6649 if (ckWARN(WARN_REDEFINE)) {
6650 GV * const gvcv = CvGV(cv);
6652 HV * const stash = GvSTASH(gvcv);
6654 const char *redefined_name = HvNAME_get(stash);
6655 if ( strEQ(redefined_name,"autouse") ) {
6656 const line_t oldline = CopLINE(PL_curcop);
6657 if (PL_parser && PL_parser->copline != NOLINE)
6658 CopLINE_set(PL_curcop, PL_parser->copline);
6659 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6660 CvCONST(cv) ? "Constant subroutine %s redefined"
6661 : "Subroutine %s redefined"
6663 CopLINE_set(PL_curcop, oldline);
6673 if (cv) /* must reuse cv if autoloaded */
6676 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6680 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6686 (void)gv_fetchfile(filename);
6687 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6688 an external constant string */
6690 CvXSUB(cv) = subaddr;
6693 process_special_blocks(name, gv, cv);
6703 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6708 OP* pegop = newOP(OP_NULL, 0);
6712 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6713 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6716 if ((cv = GvFORM(gv))) {
6717 if (ckWARN(WARN_REDEFINE)) {
6718 const line_t oldline = CopLINE(PL_curcop);
6719 if (PL_parser && PL_parser->copline != NOLINE)
6720 CopLINE_set(PL_curcop, PL_parser->copline);
6722 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6723 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6725 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6726 "Format STDOUT redefined");
6728 CopLINE_set(PL_curcop, oldline);
6735 CvFILE_set_from_cop(cv, PL_curcop);
6738 pad_tidy(padtidy_FORMAT);
6739 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6740 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6741 OpREFCNT_set(CvROOT(cv), 1);
6742 CvSTART(cv) = LINKLIST(CvROOT(cv));
6743 CvROOT(cv)->op_next = 0;
6744 CALL_PEEP(CvSTART(cv));
6746 op_getmad(o,pegop,'n');
6747 op_getmad_weak(block, pegop, 'b');
6752 PL_parser->copline = NOLINE;
6760 Perl_newANONLIST(pTHX_ OP *o)
6762 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6766 Perl_newANONHASH(pTHX_ OP *o)
6768 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6772 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6774 return newANONATTRSUB(floor, proto, NULL, block);
6778 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6780 return newUNOP(OP_REFGEN, 0,
6781 newSVOP(OP_ANONCODE, 0,
6782 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6786 Perl_oopsAV(pTHX_ OP *o)
6790 PERL_ARGS_ASSERT_OOPSAV;
6792 switch (o->op_type) {
6794 o->op_type = OP_PADAV;
6795 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6796 return ref(o, OP_RV2AV);
6799 o->op_type = OP_RV2AV;
6800 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6805 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6812 Perl_oopsHV(pTHX_ OP *o)
6816 PERL_ARGS_ASSERT_OOPSHV;
6818 switch (o->op_type) {
6821 o->op_type = OP_PADHV;
6822 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6823 return ref(o, OP_RV2HV);
6827 o->op_type = OP_RV2HV;
6828 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6833 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6840 Perl_newAVREF(pTHX_ OP *o)
6844 PERL_ARGS_ASSERT_NEWAVREF;
6846 if (o->op_type == OP_PADANY) {
6847 o->op_type = OP_PADAV;
6848 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6851 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6852 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6853 "Using an array as a reference is deprecated");
6855 return newUNOP(OP_RV2AV, 0, scalar(o));
6859 Perl_newGVREF(pTHX_ I32 type, OP *o)
6861 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6862 return newUNOP(OP_NULL, 0, o);
6863 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6867 Perl_newHVREF(pTHX_ OP *o)
6871 PERL_ARGS_ASSERT_NEWHVREF;
6873 if (o->op_type == OP_PADANY) {
6874 o->op_type = OP_PADHV;
6875 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6878 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6879 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6880 "Using a hash as a reference is deprecated");
6882 return newUNOP(OP_RV2HV, 0, scalar(o));
6886 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6888 return newUNOP(OP_RV2CV, flags, scalar(o));
6892 Perl_newSVREF(pTHX_ OP *o)
6896 PERL_ARGS_ASSERT_NEWSVREF;
6898 if (o->op_type == OP_PADANY) {
6899 o->op_type = OP_PADSV;
6900 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6903 return newUNOP(OP_RV2SV, 0, scalar(o));
6906 /* Check routines. See the comments at the top of this file for details
6907 * on when these are called */
6910 Perl_ck_anoncode(pTHX_ OP *o)
6912 PERL_ARGS_ASSERT_CK_ANONCODE;
6914 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6916 cSVOPo->op_sv = NULL;
6921 Perl_ck_bitop(pTHX_ OP *o)
6925 PERL_ARGS_ASSERT_CK_BITOP;
6927 #define OP_IS_NUMCOMPARE(op) \
6928 ((op) == OP_LT || (op) == OP_I_LT || \
6929 (op) == OP_GT || (op) == OP_I_GT || \
6930 (op) == OP_LE || (op) == OP_I_LE || \
6931 (op) == OP_GE || (op) == OP_I_GE || \
6932 (op) == OP_EQ || (op) == OP_I_EQ || \
6933 (op) == OP_NE || (op) == OP_I_NE || \
6934 (op) == OP_NCMP || (op) == OP_I_NCMP)
6935 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6936 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6937 && (o->op_type == OP_BIT_OR
6938 || o->op_type == OP_BIT_AND
6939 || o->op_type == OP_BIT_XOR))
6941 const OP * const left = cBINOPo->op_first;
6942 const OP * const right = left->op_sibling;
6943 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6944 (left->op_flags & OPf_PARENS) == 0) ||
6945 (OP_IS_NUMCOMPARE(right->op_type) &&
6946 (right->op_flags & OPf_PARENS) == 0))
6947 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6948 "Possible precedence problem on bitwise %c operator",
6949 o->op_type == OP_BIT_OR ? '|'
6950 : o->op_type == OP_BIT_AND ? '&' : '^'
6957 Perl_ck_concat(pTHX_ OP *o)
6959 const OP * const kid = cUNOPo->op_first;
6961 PERL_ARGS_ASSERT_CK_CONCAT;
6962 PERL_UNUSED_CONTEXT;
6964 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6965 !(kUNOP->op_first->op_flags & OPf_MOD))
6966 o->op_flags |= OPf_STACKED;
6971 Perl_ck_spair(pTHX_ OP *o)
6975 PERL_ARGS_ASSERT_CK_SPAIR;
6977 if (o->op_flags & OPf_KIDS) {
6980 const OPCODE type = o->op_type;
6981 o = modkids(ck_fun(o), type);
6982 kid = cUNOPo->op_first;
6983 newop = kUNOP->op_first->op_sibling;
6985 const OPCODE type = newop->op_type;
6986 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6987 type == OP_PADAV || type == OP_PADHV ||
6988 type == OP_RV2AV || type == OP_RV2HV)
6992 op_getmad(kUNOP->op_first,newop,'K');
6994 op_free(kUNOP->op_first);
6996 kUNOP->op_first = newop;
6998 o->op_ppaddr = PL_ppaddr[++o->op_type];
7003 Perl_ck_delete(pTHX_ OP *o)
7005 PERL_ARGS_ASSERT_CK_DELETE;
7009 if (o->op_flags & OPf_KIDS) {
7010 OP * const kid = cUNOPo->op_first;
7011 switch (kid->op_type) {
7013 o->op_flags |= OPf_SPECIAL;
7016 o->op_private |= OPpSLICE;
7019 o->op_flags |= OPf_SPECIAL;
7024 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7027 if (kid->op_private & OPpLVAL_INTRO)
7028 o->op_private |= OPpLVAL_INTRO;
7035 Perl_ck_die(pTHX_ OP *o)
7037 PERL_ARGS_ASSERT_CK_DIE;
7040 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7046 Perl_ck_eof(pTHX_ OP *o)
7050 PERL_ARGS_ASSERT_CK_EOF;
7052 if (o->op_flags & OPf_KIDS) {
7053 if (cLISTOPo->op_first->op_type == OP_STUB) {
7055 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7057 op_getmad(o,newop,'O');
7069 Perl_ck_eval(pTHX_ OP *o)
7073 PERL_ARGS_ASSERT_CK_EVAL;
7075 PL_hints |= HINT_BLOCK_SCOPE;
7076 if (o->op_flags & OPf_KIDS) {
7077 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7080 o->op_flags &= ~OPf_KIDS;
7083 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7089 cUNOPo->op_first = 0;
7094 NewOp(1101, enter, 1, LOGOP);
7095 enter->op_type = OP_ENTERTRY;
7096 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7097 enter->op_private = 0;
7099 /* establish postfix order */
7100 enter->op_next = (OP*)enter;
7102 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7103 o->op_type = OP_LEAVETRY;
7104 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7105 enter->op_other = o;
7106 op_getmad(oldo,o,'O');
7120 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7121 op_getmad(oldo,o,'O');
7123 o->op_targ = (PADOFFSET)PL_hints;
7124 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7125 /* Store a copy of %^H that pp_entereval can pick up. */
7126 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7127 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7128 cUNOPo->op_first->op_sibling = hhop;
7129 o->op_private |= OPpEVAL_HAS_HH;
7135 Perl_ck_exit(pTHX_ OP *o)
7137 PERL_ARGS_ASSERT_CK_EXIT;
7140 HV * const table = GvHV(PL_hintgv);
7142 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7143 if (svp && *svp && SvTRUE(*svp))
7144 o->op_private |= OPpEXIT_VMSISH;
7146 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7152 Perl_ck_exec(pTHX_ OP *o)
7154 PERL_ARGS_ASSERT_CK_EXEC;
7156 if (o->op_flags & OPf_STACKED) {
7159 kid = cUNOPo->op_first->op_sibling;
7160 if (kid->op_type == OP_RV2GV)
7169 Perl_ck_exists(pTHX_ OP *o)
7173 PERL_ARGS_ASSERT_CK_EXISTS;
7176 if (o->op_flags & OPf_KIDS) {
7177 OP * const kid = cUNOPo->op_first;
7178 if (kid->op_type == OP_ENTERSUB) {
7179 (void) ref(kid, o->op_type);
7180 if (kid->op_type != OP_RV2CV
7181 && !(PL_parser && PL_parser->error_count))
7182 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7184 o->op_private |= OPpEXISTS_SUB;
7186 else if (kid->op_type == OP_AELEM)
7187 o->op_flags |= OPf_SPECIAL;
7188 else if (kid->op_type != OP_HELEM)
7189 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7197 Perl_ck_rvconst(pTHX_ register OP *o)
7200 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7202 PERL_ARGS_ASSERT_CK_RVCONST;
7204 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7205 if (o->op_type == OP_RV2CV)
7206 o->op_private &= ~1;
7208 if (kid->op_type == OP_CONST) {
7211 SV * const kidsv = kid->op_sv;
7213 /* Is it a constant from cv_const_sv()? */
7214 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7215 SV * const rsv = SvRV(kidsv);
7216 const svtype type = SvTYPE(rsv);
7217 const char *badtype = NULL;
7219 switch (o->op_type) {
7221 if (type > SVt_PVMG)
7222 badtype = "a SCALAR";
7225 if (type != SVt_PVAV)
7226 badtype = "an ARRAY";
7229 if (type != SVt_PVHV)
7233 if (type != SVt_PVCV)
7238 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7241 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7242 const char *badthing;
7243 switch (o->op_type) {
7245 badthing = "a SCALAR";
7248 badthing = "an ARRAY";
7251 badthing = "a HASH";
7259 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7260 SVfARG(kidsv), badthing);
7263 * This is a little tricky. We only want to add the symbol if we
7264 * didn't add it in the lexer. Otherwise we get duplicate strict
7265 * warnings. But if we didn't add it in the lexer, we must at
7266 * least pretend like we wanted to add it even if it existed before,
7267 * or we get possible typo warnings. OPpCONST_ENTERED says
7268 * whether the lexer already added THIS instance of this symbol.
7270 iscv = (o->op_type == OP_RV2CV) * 2;
7272 gv = gv_fetchsv(kidsv,
7273 iscv | !(kid->op_private & OPpCONST_ENTERED),
7276 : o->op_type == OP_RV2SV
7278 : o->op_type == OP_RV2AV
7280 : o->op_type == OP_RV2HV
7283 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7285 kid->op_type = OP_GV;
7286 SvREFCNT_dec(kid->op_sv);
7288 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7289 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7290 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7292 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7294 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7296 kid->op_private = 0;
7297 kid->op_ppaddr = PL_ppaddr[OP_GV];
7298 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7306 Perl_ck_ftst(pTHX_ OP *o)
7309 const I32 type = o->op_type;
7311 PERL_ARGS_ASSERT_CK_FTST;
7313 if (o->op_flags & OPf_REF) {
7316 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7317 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7318 const OPCODE kidtype = kid->op_type;
7320 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7321 OP * const newop = newGVOP(type, OPf_REF,
7322 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7324 op_getmad(o,newop,'O');
7330 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7331 o->op_private |= OPpFT_ACCESS;
7332 if (PL_check[kidtype] == Perl_ck_ftst
7333 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7334 o->op_private |= OPpFT_STACKED;
7342 if (type == OP_FTTTY)
7343 o = newGVOP(type, OPf_REF, PL_stdingv);
7345 o = newUNOP(type, 0, newDEFSVOP());
7346 op_getmad(oldo,o,'O');
7352 Perl_ck_fun(pTHX_ OP *o)
7355 const int type = o->op_type;
7356 register I32 oa = PL_opargs[type] >> OASHIFT;
7358 PERL_ARGS_ASSERT_CK_FUN;
7360 if (o->op_flags & OPf_STACKED) {
7361 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7364 return no_fh_allowed(o);
7367 if (o->op_flags & OPf_KIDS) {
7368 OP **tokid = &cLISTOPo->op_first;
7369 register OP *kid = cLISTOPo->op_first;
7373 if (kid->op_type == OP_PUSHMARK ||
7374 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7376 tokid = &kid->op_sibling;
7377 kid = kid->op_sibling;
7379 if (!kid && PL_opargs[type] & OA_DEFGV)
7380 *tokid = kid = newDEFSVOP();
7384 sibl = kid->op_sibling;
7386 if (!sibl && kid->op_type == OP_STUB) {
7393 /* list seen where single (scalar) arg expected? */
7394 if (numargs == 1 && !(oa >> 4)
7395 && kid->op_type == OP_LIST && type != OP_SCALAR)
7397 return too_many_arguments(o,PL_op_desc[type]);
7410 if ((type == OP_PUSH || type == OP_UNSHIFT)
7411 && !kid->op_sibling)
7412 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7413 "Useless use of %s with no values",
7416 if (kid->op_type == OP_CONST &&
7417 (kid->op_private & OPpCONST_BARE))
7419 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7420 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7421 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7422 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7423 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7425 op_getmad(kid,newop,'K');
7430 kid->op_sibling = sibl;
7433 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7434 bad_type(numargs, "array", PL_op_desc[type], kid);
7435 op_lvalue(kid, type);
7438 if (kid->op_type == OP_CONST &&
7439 (kid->op_private & OPpCONST_BARE))
7441 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7442 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7443 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7444 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7445 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7447 op_getmad(kid,newop,'K');
7452 kid->op_sibling = sibl;
7455 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7456 bad_type(numargs, "hash", PL_op_desc[type], kid);
7457 op_lvalue(kid, type);
7461 OP * const newop = newUNOP(OP_NULL, 0, kid);
7462 kid->op_sibling = 0;
7464 newop->op_next = newop;
7466 kid->op_sibling = sibl;
7471 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7472 if (kid->op_type == OP_CONST &&
7473 (kid->op_private & OPpCONST_BARE))
7475 OP * const newop = newGVOP(OP_GV, 0,
7476 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7477 if (!(o->op_private & 1) && /* if not unop */
7478 kid == cLISTOPo->op_last)
7479 cLISTOPo->op_last = newop;
7481 op_getmad(kid,newop,'K');
7487 else if (kid->op_type == OP_READLINE) {
7488 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7489 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7492 I32 flags = OPf_SPECIAL;
7496 /* is this op a FH constructor? */
7497 if (is_handle_constructor(o,numargs)) {
7498 const char *name = NULL;
7502 /* Set a flag to tell rv2gv to vivify
7503 * need to "prove" flag does not mean something
7504 * else already - NI-S 1999/05/07
7507 if (kid->op_type == OP_PADSV) {
7509 = PAD_COMPNAME_SV(kid->op_targ);
7510 name = SvPV_const(namesv, len);
7512 else if (kid->op_type == OP_RV2SV
7513 && kUNOP->op_first->op_type == OP_GV)
7515 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7517 len = GvNAMELEN(gv);
7519 else if (kid->op_type == OP_AELEM
7520 || kid->op_type == OP_HELEM)
7523 OP *op = ((BINOP*)kid)->op_first;
7527 const char * const a =
7528 kid->op_type == OP_AELEM ?
7530 if (((op->op_type == OP_RV2AV) ||
7531 (op->op_type == OP_RV2HV)) &&
7532 (firstop = ((UNOP*)op)->op_first) &&
7533 (firstop->op_type == OP_GV)) {
7534 /* packagevar $a[] or $h{} */
7535 GV * const gv = cGVOPx_gv(firstop);
7543 else if (op->op_type == OP_PADAV
7544 || op->op_type == OP_PADHV) {
7545 /* lexicalvar $a[] or $h{} */
7546 const char * const padname =
7547 PAD_COMPNAME_PV(op->op_targ);
7556 name = SvPV_const(tmpstr, len);
7561 name = "__ANONIO__";
7564 op_lvalue(kid, type);
7568 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7569 namesv = PAD_SVl(targ);
7570 SvUPGRADE(namesv, SVt_PV);
7572 sv_setpvs(namesv, "$");
7573 sv_catpvn(namesv, name, len);
7576 kid->op_sibling = 0;
7577 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7578 kid->op_targ = targ;
7579 kid->op_private |= priv;
7581 kid->op_sibling = sibl;
7587 op_lvalue(scalar(kid), type);
7591 tokid = &kid->op_sibling;
7592 kid = kid->op_sibling;
7595 if (kid && kid->op_type != OP_STUB)
7596 return too_many_arguments(o,OP_DESC(o));
7597 o->op_private |= numargs;
7599 /* FIXME - should the numargs move as for the PERL_MAD case? */
7600 o->op_private |= numargs;
7602 return too_many_arguments(o,OP_DESC(o));
7606 else if (PL_opargs[type] & OA_DEFGV) {
7608 OP *newop = newUNOP(type, 0, newDEFSVOP());
7609 op_getmad(o,newop,'O');
7612 /* Ordering of these two is important to keep f_map.t passing. */
7614 return newUNOP(type, 0, newDEFSVOP());
7619 while (oa & OA_OPTIONAL)
7621 if (oa && oa != OA_LIST)
7622 return too_few_arguments(o,OP_DESC(o));
7628 Perl_ck_glob(pTHX_ OP *o)
7633 PERL_ARGS_ASSERT_CK_GLOB;
7636 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7637 op_append_elem(OP_GLOB, o, newDEFSVOP());
7639 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7640 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7642 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7645 #if !defined(PERL_EXTERNAL_GLOB)
7646 /* XXX this can be tightened up and made more failsafe. */
7647 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7650 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7651 newSVpvs("File::Glob"), NULL, NULL, NULL);
7652 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7653 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7654 GvCV(gv) = GvCV(glob_gv);
7655 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7656 GvIMPORTED_CV_on(gv);
7660 #endif /* PERL_EXTERNAL_GLOB */
7662 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7663 op_append_elem(OP_GLOB, o,
7664 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7665 o->op_type = OP_LIST;
7666 o->op_ppaddr = PL_ppaddr[OP_LIST];
7667 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7668 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7669 cLISTOPo->op_first->op_targ = 0;
7670 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7671 op_append_elem(OP_LIST, o,
7672 scalar(newUNOP(OP_RV2CV, 0,
7673 newGVOP(OP_GV, 0, gv)))));
7674 o = newUNOP(OP_NULL, 0, ck_subr(o));
7675 o->op_targ = OP_GLOB; /* hint at what it used to be */
7678 gv = newGVgen("main");
7680 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7686 Perl_ck_grep(pTHX_ OP *o)
7691 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7694 PERL_ARGS_ASSERT_CK_GREP;
7696 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7697 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7699 if (o->op_flags & OPf_STACKED) {
7702 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7703 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7704 return no_fh_allowed(o);
7705 for (k = kid; k; k = k->op_next) {
7708 NewOp(1101, gwop, 1, LOGOP);
7709 kid->op_next = (OP*)gwop;
7710 o->op_flags &= ~OPf_STACKED;
7712 kid = cLISTOPo->op_first->op_sibling;
7713 if (type == OP_MAPWHILE)
7718 if (PL_parser && PL_parser->error_count)
7720 kid = cLISTOPo->op_first->op_sibling;
7721 if (kid->op_type != OP_NULL)
7722 Perl_croak(aTHX_ "panic: ck_grep");
7723 kid = kUNOP->op_first;
7726 NewOp(1101, gwop, 1, LOGOP);
7727 gwop->op_type = type;
7728 gwop->op_ppaddr = PL_ppaddr[type];
7729 gwop->op_first = listkids(o);
7730 gwop->op_flags |= OPf_KIDS;
7731 gwop->op_other = LINKLIST(kid);
7732 kid->op_next = (OP*)gwop;
7733 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7734 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7735 o->op_private = gwop->op_private = 0;
7736 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7739 o->op_private = gwop->op_private = OPpGREP_LEX;
7740 gwop->op_targ = o->op_targ = offset;
7743 kid = cLISTOPo->op_first->op_sibling;
7744 if (!kid || !kid->op_sibling)
7745 return too_few_arguments(o,OP_DESC(o));
7746 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7747 op_lvalue(kid, OP_GREPSTART);
7753 Perl_ck_index(pTHX_ OP *o)
7755 PERL_ARGS_ASSERT_CK_INDEX;
7757 if (o->op_flags & OPf_KIDS) {
7758 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7760 kid = kid->op_sibling; /* get past "big" */
7761 if (kid && kid->op_type == OP_CONST)
7762 fbm_compile(((SVOP*)kid)->op_sv, 0);
7768 Perl_ck_lfun(pTHX_ OP *o)
7770 const OPCODE type = o->op_type;
7772 PERL_ARGS_ASSERT_CK_LFUN;
7774 return modkids(ck_fun(o), type);
7778 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7780 PERL_ARGS_ASSERT_CK_DEFINED;
7782 if ((o->op_flags & OPf_KIDS)) {
7783 switch (cUNOPo->op_first->op_type) {
7785 /* This is needed for
7786 if (defined %stash::)
7787 to work. Do not break Tk.
7789 break; /* Globals via GV can be undef */
7791 case OP_AASSIGN: /* Is this a good idea? */
7792 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7793 "defined(@array) is deprecated");
7794 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7795 "\t(Maybe you should just omit the defined()?)\n");
7799 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7800 "defined(%%hash) is deprecated");
7801 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7802 "\t(Maybe you should just omit the defined()?)\n");
7813 Perl_ck_readline(pTHX_ OP *o)
7815 PERL_ARGS_ASSERT_CK_READLINE;
7817 if (!(o->op_flags & OPf_KIDS)) {
7819 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7821 op_getmad(o,newop,'O');
7831 Perl_ck_rfun(pTHX_ OP *o)
7833 const OPCODE type = o->op_type;
7835 PERL_ARGS_ASSERT_CK_RFUN;
7837 return refkids(ck_fun(o), type);
7841 Perl_ck_listiob(pTHX_ OP *o)
7845 PERL_ARGS_ASSERT_CK_LISTIOB;
7847 kid = cLISTOPo->op_first;
7850 kid = cLISTOPo->op_first;
7852 if (kid->op_type == OP_PUSHMARK)
7853 kid = kid->op_sibling;
7854 if (kid && o->op_flags & OPf_STACKED)
7855 kid = kid->op_sibling;
7856 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7857 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7858 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7859 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7860 cLISTOPo->op_first->op_sibling = kid;
7861 cLISTOPo->op_last = kid;
7862 kid = kid->op_sibling;
7867 op_append_elem(o->op_type, o, newDEFSVOP());
7873 Perl_ck_smartmatch(pTHX_ OP *o)
7876 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7877 if (0 == (o->op_flags & OPf_SPECIAL)) {
7878 OP *first = cBINOPo->op_first;
7879 OP *second = first->op_sibling;
7881 /* Implicitly take a reference to an array or hash */
7882 first->op_sibling = NULL;
7883 first = cBINOPo->op_first = ref_array_or_hash(first);
7884 second = first->op_sibling = ref_array_or_hash(second);
7886 /* Implicitly take a reference to a regular expression */
7887 if (first->op_type == OP_MATCH) {
7888 first->op_type = OP_QR;
7889 first->op_ppaddr = PL_ppaddr[OP_QR];
7891 if (second->op_type == OP_MATCH) {
7892 second->op_type = OP_QR;
7893 second->op_ppaddr = PL_ppaddr[OP_QR];
7902 Perl_ck_sassign(pTHX_ OP *o)
7905 OP * const kid = cLISTOPo->op_first;
7907 PERL_ARGS_ASSERT_CK_SASSIGN;
7909 /* has a disposable target? */
7910 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7911 && !(kid->op_flags & OPf_STACKED)
7912 /* Cannot steal the second time! */
7913 && !(kid->op_private & OPpTARGET_MY)
7914 /* Keep the full thing for madskills */
7918 OP * const kkid = kid->op_sibling;
7920 /* Can just relocate the target. */
7921 if (kkid && kkid->op_type == OP_PADSV
7922 && !(kkid->op_private & OPpLVAL_INTRO))
7924 kid->op_targ = kkid->op_targ;
7926 /* Now we do not need PADSV and SASSIGN. */
7927 kid->op_sibling = o->op_sibling; /* NULL */
7928 cLISTOPo->op_first = NULL;
7931 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7935 if (kid->op_sibling) {
7936 OP *kkid = kid->op_sibling;
7937 if (kkid->op_type == OP_PADSV
7938 && (kkid->op_private & OPpLVAL_INTRO)
7939 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7940 const PADOFFSET target = kkid->op_targ;
7941 OP *const other = newOP(OP_PADSV,
7943 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7944 OP *const first = newOP(OP_NULL, 0);
7945 OP *const nullop = newCONDOP(0, first, o, other);
7946 OP *const condop = first->op_next;
7947 /* hijacking PADSTALE for uninitialized state variables */
7948 SvPADSTALE_on(PAD_SVl(target));
7950 condop->op_type = OP_ONCE;
7951 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7952 condop->op_targ = target;
7953 other->op_targ = target;
7955 /* Because we change the type of the op here, we will skip the
7956 assinment binop->op_last = binop->op_first->op_sibling; at the
7957 end of Perl_newBINOP(). So need to do it here. */
7958 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7967 Perl_ck_match(pTHX_ OP *o)
7971 PERL_ARGS_ASSERT_CK_MATCH;
7973 if (o->op_type != OP_QR && PL_compcv) {
7974 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7975 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7976 o->op_targ = offset;
7977 o->op_private |= OPpTARGET_MY;
7980 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7981 o->op_private |= OPpRUNTIME;
7986 Perl_ck_method(pTHX_ OP *o)
7988 OP * const kid = cUNOPo->op_first;
7990 PERL_ARGS_ASSERT_CK_METHOD;
7992 if (kid->op_type == OP_CONST) {
7993 SV* sv = kSVOP->op_sv;
7994 const char * const method = SvPVX_const(sv);
7995 if (!(strchr(method, ':') || strchr(method, '\''))) {
7997 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7998 sv = newSVpvn_share(method, SvCUR(sv), 0);
8001 kSVOP->op_sv = NULL;
8003 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8005 op_getmad(o,cmop,'O');
8016 Perl_ck_null(pTHX_ OP *o)
8018 PERL_ARGS_ASSERT_CK_NULL;
8019 PERL_UNUSED_CONTEXT;
8024 Perl_ck_open(pTHX_ OP *o)
8027 HV * const table = GvHV(PL_hintgv);
8029 PERL_ARGS_ASSERT_CK_OPEN;
8032 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8035 const char *d = SvPV_const(*svp, len);
8036 const I32 mode = mode_from_discipline(d, len);
8037 if (mode & O_BINARY)
8038 o->op_private |= OPpOPEN_IN_RAW;
8039 else if (mode & O_TEXT)
8040 o->op_private |= OPpOPEN_IN_CRLF;
8043 svp = hv_fetchs(table, "open_OUT", FALSE);
8046 const char *d = SvPV_const(*svp, len);
8047 const I32 mode = mode_from_discipline(d, len);
8048 if (mode & O_BINARY)
8049 o->op_private |= OPpOPEN_OUT_RAW;
8050 else if (mode & O_TEXT)
8051 o->op_private |= OPpOPEN_OUT_CRLF;
8054 if (o->op_type == OP_BACKTICK) {
8055 if (!(o->op_flags & OPf_KIDS)) {
8056 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8058 op_getmad(o,newop,'O');
8067 /* In case of three-arg dup open remove strictness
8068 * from the last arg if it is a bareword. */
8069 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8070 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8074 if ((last->op_type == OP_CONST) && /* The bareword. */
8075 (last->op_private & OPpCONST_BARE) &&
8076 (last->op_private & OPpCONST_STRICT) &&
8077 (oa = first->op_sibling) && /* The fh. */
8078 (oa = oa->op_sibling) && /* The mode. */
8079 (oa->op_type == OP_CONST) &&
8080 SvPOK(((SVOP*)oa)->op_sv) &&
8081 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8082 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8083 (last == oa->op_sibling)) /* The bareword. */
8084 last->op_private &= ~OPpCONST_STRICT;
8090 Perl_ck_repeat(pTHX_ OP *o)
8092 PERL_ARGS_ASSERT_CK_REPEAT;
8094 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8095 o->op_private |= OPpREPEAT_DOLIST;
8096 cBINOPo->op_first = force_list(cBINOPo->op_first);
8104 Perl_ck_require(pTHX_ OP *o)
8109 PERL_ARGS_ASSERT_CK_REQUIRE;
8111 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8112 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8114 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8115 SV * const sv = kid->op_sv;
8116 U32 was_readonly = SvREADONLY(sv);
8123 sv_force_normal_flags(sv, 0);
8124 assert(!SvREADONLY(sv));
8134 for (; s < end; s++) {
8135 if (*s == ':' && s[1] == ':') {
8137 Move(s+2, s+1, end - s - 1, char);
8142 sv_catpvs(sv, ".pm");
8143 SvFLAGS(sv) |= was_readonly;
8147 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8148 /* handle override, if any */
8149 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8150 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8151 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8152 gv = gvp ? *gvp : NULL;
8156 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8157 OP * const kid = cUNOPo->op_first;
8160 cUNOPo->op_first = 0;
8164 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8165 op_append_elem(OP_LIST, kid,
8166 scalar(newUNOP(OP_RV2CV, 0,
8169 op_getmad(o,newop,'O');
8173 return scalar(ck_fun(o));
8177 Perl_ck_return(pTHX_ OP *o)
8182 PERL_ARGS_ASSERT_CK_RETURN;
8184 kid = cLISTOPo->op_first->op_sibling;
8185 if (CvLVALUE(PL_compcv)) {
8186 for (; kid; kid = kid->op_sibling)
8187 op_lvalue(kid, OP_LEAVESUBLV);
8189 for (; kid; kid = kid->op_sibling)
8190 if ((kid->op_type == OP_NULL)
8191 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8192 /* This is a do block */
8193 OP *op = kUNOP->op_first;
8194 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8195 op = cUNOPx(op)->op_first;
8196 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8197 /* Force the use of the caller's context */
8198 op->op_flags |= OPf_SPECIAL;
8207 Perl_ck_select(pTHX_ OP *o)
8212 PERL_ARGS_ASSERT_CK_SELECT;
8214 if (o->op_flags & OPf_KIDS) {
8215 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8216 if (kid && kid->op_sibling) {
8217 o->op_type = OP_SSELECT;
8218 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8220 return fold_constants(o);
8224 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8225 if (kid && kid->op_type == OP_RV2GV)
8226 kid->op_private &= ~HINT_STRICT_REFS;
8231 Perl_ck_shift(pTHX_ OP *o)
8234 const I32 type = o->op_type;
8236 PERL_ARGS_ASSERT_CK_SHIFT;
8238 if (!(o->op_flags & OPf_KIDS)) {
8241 if (!CvUNIQUE(PL_compcv)) {
8242 o->op_flags |= OPf_SPECIAL;
8246 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8249 OP * const oldo = o;
8250 o = newUNOP(type, 0, scalar(argop));
8251 op_getmad(oldo,o,'O');
8256 return newUNOP(type, 0, scalar(argop));
8259 return scalar(modkids(ck_push(o), type));
8263 Perl_ck_sort(pTHX_ OP *o)
8268 PERL_ARGS_ASSERT_CK_SORT;
8270 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8271 HV * const hinthv = GvHV(PL_hintgv);
8273 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8275 const I32 sorthints = (I32)SvIV(*svp);
8276 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8277 o->op_private |= OPpSORT_QSORT;
8278 if ((sorthints & HINT_SORT_STABLE) != 0)
8279 o->op_private |= OPpSORT_STABLE;
8284 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8286 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8287 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8289 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8291 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8293 if (kid->op_type == OP_SCOPE) {
8297 else if (kid->op_type == OP_LEAVE) {
8298 if (o->op_type == OP_SORT) {
8299 op_null(kid); /* wipe out leave */
8302 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8303 if (k->op_next == kid)
8305 /* don't descend into loops */
8306 else if (k->op_type == OP_ENTERLOOP
8307 || k->op_type == OP_ENTERITER)
8309 k = cLOOPx(k)->op_lastop;
8314 kid->op_next = 0; /* just disconnect the leave */
8315 k = kLISTOP->op_first;
8320 if (o->op_type == OP_SORT) {
8321 /* provide scalar context for comparison function/block */
8327 o->op_flags |= OPf_SPECIAL;
8329 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8332 firstkid = firstkid->op_sibling;
8335 /* provide list context for arguments */
8336 if (o->op_type == OP_SORT)
8343 S_simplify_sort(pTHX_ OP *o)
8346 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8352 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8354 if (!(o->op_flags & OPf_STACKED))
8356 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8357 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8358 kid = kUNOP->op_first; /* get past null */
8359 if (kid->op_type != OP_SCOPE)
8361 kid = kLISTOP->op_last; /* get past scope */
8362 switch(kid->op_type) {
8370 k = kid; /* remember this node*/
8371 if (kBINOP->op_first->op_type != OP_RV2SV)
8373 kid = kBINOP->op_first; /* get past cmp */
8374 if (kUNOP->op_first->op_type != OP_GV)
8376 kid = kUNOP->op_first; /* get past rv2sv */
8378 if (GvSTASH(gv) != PL_curstash)
8380 gvname = GvNAME(gv);
8381 if (*gvname == 'a' && gvname[1] == '\0')
8383 else if (*gvname == 'b' && gvname[1] == '\0')
8388 kid = k; /* back to cmp */
8389 if (kBINOP->op_last->op_type != OP_RV2SV)
8391 kid = kBINOP->op_last; /* down to 2nd arg */
8392 if (kUNOP->op_first->op_type != OP_GV)
8394 kid = kUNOP->op_first; /* get past rv2sv */
8396 if (GvSTASH(gv) != PL_curstash)
8398 gvname = GvNAME(gv);
8400 ? !(*gvname == 'a' && gvname[1] == '\0')
8401 : !(*gvname == 'b' && gvname[1] == '\0'))
8403 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8405 o->op_private |= OPpSORT_DESCEND;
8406 if (k->op_type == OP_NCMP)
8407 o->op_private |= OPpSORT_NUMERIC;
8408 if (k->op_type == OP_I_NCMP)
8409 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8410 kid = cLISTOPo->op_first->op_sibling;
8411 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8413 op_getmad(kid,o,'S'); /* then delete it */
8415 op_free(kid); /* then delete it */
8420 Perl_ck_split(pTHX_ OP *o)
8425 PERL_ARGS_ASSERT_CK_SPLIT;
8427 if (o->op_flags & OPf_STACKED)
8428 return no_fh_allowed(o);
8430 kid = cLISTOPo->op_first;
8431 if (kid->op_type != OP_NULL)
8432 Perl_croak(aTHX_ "panic: ck_split");
8433 kid = kid->op_sibling;
8434 op_free(cLISTOPo->op_first);
8435 cLISTOPo->op_first = kid;
8437 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8438 cLISTOPo->op_last = kid; /* There was only one element previously */
8441 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8442 OP * const sibl = kid->op_sibling;
8443 kid->op_sibling = 0;
8444 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8445 if (cLISTOPo->op_first == cLISTOPo->op_last)
8446 cLISTOPo->op_last = kid;
8447 cLISTOPo->op_first = kid;
8448 kid->op_sibling = sibl;
8451 kid->op_type = OP_PUSHRE;
8452 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8454 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8455 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8456 "Use of /g modifier is meaningless in split");
8459 if (!kid->op_sibling)
8460 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8462 kid = kid->op_sibling;
8465 if (!kid->op_sibling)
8466 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8467 assert(kid->op_sibling);
8469 kid = kid->op_sibling;
8472 if (kid->op_sibling)
8473 return too_many_arguments(o,OP_DESC(o));
8479 Perl_ck_join(pTHX_ OP *o)
8481 const OP * const kid = cLISTOPo->op_first->op_sibling;
8483 PERL_ARGS_ASSERT_CK_JOIN;
8485 if (kid && kid->op_type == OP_MATCH) {
8486 if (ckWARN(WARN_SYNTAX)) {
8487 const REGEXP *re = PM_GETRE(kPMOP);
8488 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8489 const STRLEN len = re ? RX_PRELEN(re) : 6;
8490 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8491 "/%.*s/ should probably be written as \"%.*s\"",
8492 (int)len, pmstr, (int)len, pmstr);
8499 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8501 Examines an op, which is expected to identify a subroutine at runtime,
8502 and attempts to determine at compile time which subroutine it identifies.
8503 This is normally used during Perl compilation to determine whether
8504 a prototype can be applied to a function call. I<cvop> is the op
8505 being considered, normally an C<rv2cv> op. A pointer to the identified
8506 subroutine is returned, if it could be determined statically, and a null
8507 pointer is returned if it was not possible to determine statically.
8509 Currently, the subroutine can be identified statically if the RV that the
8510 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8511 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8512 suitable if the constant value must be an RV pointing to a CV. Details of
8513 this process may change in future versions of Perl. If the C<rv2cv> op
8514 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8515 the subroutine statically: this flag is used to suppress compile-time
8516 magic on a subroutine call, forcing it to use default runtime behaviour.
8518 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8519 of a GV reference is modified. If a GV was examined and its CV slot was
8520 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8521 If the op is not optimised away, and the CV slot is later populated with
8522 a subroutine having a prototype, that flag eventually triggers the warning
8523 "called too early to check prototype".
8525 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8526 of returning a pointer to the subroutine it returns a pointer to the
8527 GV giving the most appropriate name for the subroutine in this context.
8528 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8529 (C<CvANON>) subroutine that is referenced through a GV it will be the
8530 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8531 A null pointer is returned as usual if there is no statically-determinable
8538 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8543 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8544 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8545 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8546 if (cvop->op_type != OP_RV2CV)
8548 if (cvop->op_private & OPpENTERSUB_AMPER)
8550 if (!(cvop->op_flags & OPf_KIDS))
8552 rvop = cUNOPx(cvop)->op_first;
8553 switch (rvop->op_type) {
8555 gv = cGVOPx_gv(rvop);
8558 if (flags & RV2CVOPCV_MARK_EARLY)
8559 rvop->op_private |= OPpEARLY_CV;
8564 SV *rv = cSVOPx_sv(rvop);
8574 if (SvTYPE((SV*)cv) != SVt_PVCV)
8576 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8577 if (!CvANON(cv) || !gv)
8586 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8588 Performs the default fixup of the arguments part of an C<entersub>
8589 op tree. This consists of applying list context to each of the
8590 argument ops. This is the standard treatment used on a call marked
8591 with C<&>, or a method call, or a call through a subroutine reference,
8592 or any other call where the callee can't be identified at compile time,
8593 or a call where the callee has no prototype.
8599 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8602 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8603 aop = cUNOPx(entersubop)->op_first;
8604 if (!aop->op_sibling)
8605 aop = cUNOPx(aop)->op_first;
8606 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8607 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8609 op_lvalue(aop, OP_ENTERSUB);
8616 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8618 Performs the fixup of the arguments part of an C<entersub> op tree
8619 based on a subroutine prototype. This makes various modifications to
8620 the argument ops, from applying context up to inserting C<refgen> ops,
8621 and checking the number and syntactic types of arguments, as directed by
8622 the prototype. This is the standard treatment used on a subroutine call,
8623 not marked with C<&>, where the callee can be identified at compile time
8624 and has a prototype.
8626 I<protosv> supplies the subroutine prototype to be applied to the call.
8627 It may be a normal defined scalar, of which the string value will be used.
8628 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8629 that has been cast to C<SV*>) which has a prototype. The prototype
8630 supplied, in whichever form, does not need to match the actual callee
8631 referenced by the op tree.
8633 If the argument ops disagree with the prototype, for example by having
8634 an unacceptable number of arguments, a valid op tree is returned anyway.
8635 The error is reflected in the parser state, normally resulting in a single
8636 exception at the top level of parsing which covers all the compilation
8637 errors that occurred. In the error message, the callee is referred to
8638 by the name defined by the I<namegv> parameter.
8644 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8647 const char *proto, *proto_end;
8648 OP *aop, *prev, *cvop;
8651 I32 contextclass = 0;
8652 const char *e = NULL;
8653 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8654 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8655 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8656 proto = SvPV(protosv, proto_len);
8657 proto_end = proto + proto_len;
8658 aop = cUNOPx(entersubop)->op_first;
8659 if (!aop->op_sibling)
8660 aop = cUNOPx(aop)->op_first;
8662 aop = aop->op_sibling;
8663 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8664 while (aop != cvop) {
8666 if (PL_madskills && aop->op_type == OP_STUB) {
8667 aop = aop->op_sibling;
8670 if (PL_madskills && aop->op_type == OP_NULL)
8671 o3 = ((UNOP*)aop)->op_first;
8675 if (proto >= proto_end)
8676 return too_many_arguments(entersubop, gv_ename(namegv));
8684 /* _ must be at the end */
8685 if (proto[1] && proto[1] != ';')
8700 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8702 arg == 1 ? "block or sub {}" : "sub {}",
8703 gv_ename(namegv), o3);
8706 /* '*' allows any scalar type, including bareword */
8709 if (o3->op_type == OP_RV2GV)
8710 goto wrapref; /* autoconvert GLOB -> GLOBref */
8711 else if (o3->op_type == OP_CONST)
8712 o3->op_private &= ~OPpCONST_STRICT;
8713 else if (o3->op_type == OP_ENTERSUB) {
8714 /* accidental subroutine, revert to bareword */
8715 OP *gvop = ((UNOP*)o3)->op_first;
8716 if (gvop && gvop->op_type == OP_NULL) {
8717 gvop = ((UNOP*)gvop)->op_first;
8719 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8722 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8723 (gvop = ((UNOP*)gvop)->op_first) &&
8724 gvop->op_type == OP_GV)
8726 GV * const gv = cGVOPx_gv(gvop);
8727 OP * const sibling = aop->op_sibling;
8728 SV * const n = newSVpvs("");
8730 OP * const oldaop = aop;
8734 gv_fullname4(n, gv, "", FALSE);
8735 aop = newSVOP(OP_CONST, 0, n);
8736 op_getmad(oldaop,aop,'O');
8737 prev->op_sibling = aop;
8738 aop->op_sibling = sibling;
8748 if (o3->op_type == OP_RV2AV ||
8749 o3->op_type == OP_PADAV ||
8750 o3->op_type == OP_RV2HV ||
8751 o3->op_type == OP_PADHV
8766 if (contextclass++ == 0) {
8767 e = strchr(proto, ']');
8768 if (!e || e == proto)
8777 const char *p = proto;
8778 const char *const end = proto;
8780 while (*--p != '[') {}
8781 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8783 gv_ename(namegv), o3);
8788 if (o3->op_type == OP_RV2GV)
8791 bad_type(arg, "symbol", gv_ename(namegv), o3);
8794 if (o3->op_type == OP_ENTERSUB)
8797 bad_type(arg, "subroutine entry", gv_ename(namegv),
8801 if (o3->op_type == OP_RV2SV ||
8802 o3->op_type == OP_PADSV ||
8803 o3->op_type == OP_HELEM ||
8804 o3->op_type == OP_AELEM)
8807 bad_type(arg, "scalar", gv_ename(namegv), o3);
8810 if (o3->op_type == OP_RV2AV ||
8811 o3->op_type == OP_PADAV)
8814 bad_type(arg, "array", gv_ename(namegv), o3);
8817 if (o3->op_type == OP_RV2HV ||
8818 o3->op_type == OP_PADHV)
8821 bad_type(arg, "hash", gv_ename(namegv), o3);
8825 OP* const kid = aop;
8826 OP* const sib = kid->op_sibling;
8827 kid->op_sibling = 0;
8828 aop = newUNOP(OP_REFGEN, 0, kid);
8829 aop->op_sibling = sib;
8830 prev->op_sibling = aop;
8832 if (contextclass && e) {
8847 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8848 gv_ename(namegv), SVfARG(protosv));
8851 op_lvalue(aop, OP_ENTERSUB);
8853 aop = aop->op_sibling;
8855 if (aop == cvop && *proto == '_') {
8856 /* generate an access to $_ */
8858 aop->op_sibling = prev->op_sibling;
8859 prev->op_sibling = aop; /* instead of cvop */
8861 if (!optional && proto_end > proto &&
8862 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8863 return too_few_arguments(entersubop, gv_ename(namegv));
8868 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8870 Performs the fixup of the arguments part of an C<entersub> op tree either
8871 based on a subroutine prototype or using default list-context processing.
8872 This is the standard treatment used on a subroutine call, not marked
8873 with C<&>, where the callee can be identified at compile time.
8875 I<protosv> supplies the subroutine prototype to be applied to the call,
8876 or indicates that there is no prototype. It may be a normal scalar,
8877 in which case if it is defined then the string value will be used
8878 as a prototype, and if it is undefined then there is no prototype.
8879 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8880 that has been cast to C<SV*>), of which the prototype will be used if it
8881 has one. The prototype (or lack thereof) supplied, in whichever form,
8882 does not need to match the actual callee referenced by the op tree.
8884 If the argument ops disagree with the prototype, for example by having
8885 an unacceptable number of arguments, a valid op tree is returned anyway.
8886 The error is reflected in the parser state, normally resulting in a single
8887 exception at the top level of parsing which covers all the compilation
8888 errors that occurred. In the error message, the callee is referred to
8889 by the name defined by the I<namegv> parameter.
8895 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8896 GV *namegv, SV *protosv)
8898 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8899 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8900 return ck_entersub_args_proto(entersubop, namegv, protosv);
8902 return ck_entersub_args_list(entersubop);
8906 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8908 Retrieves the function that will be used to fix up a call to I<cv>.
8909 Specifically, the function is applied to an C<entersub> op tree for a
8910 subroutine call, not marked with C<&>, where the callee can be identified
8911 at compile time as I<cv>.
8913 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8914 argument for it is returned in I<*ckobj_p>. The function is intended
8915 to be called in this manner:
8917 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8919 In this call, I<entersubop> is a pointer to the C<entersub> op,
8920 which may be replaced by the check function, and I<namegv> is a GV
8921 supplying the name that should be used by the check function to refer
8922 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8923 It is permitted to apply the check function in non-standard situations,
8924 such as to a call to a different subroutine or to a method call.
8926 By default, the function is
8927 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8928 and the SV parameter is I<cv> itself. This implements standard
8929 prototype processing. It can be changed, for a particular subroutine,
8930 by L</cv_set_call_checker>.
8936 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8939 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8940 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8942 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8943 *ckobj_p = callmg->mg_obj;
8945 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8951 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8953 Sets the function that will be used to fix up a call to I<cv>.
8954 Specifically, the function is applied to an C<entersub> op tree for a
8955 subroutine call, not marked with C<&>, where the callee can be identified
8956 at compile time as I<cv>.
8958 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8959 for it is supplied in I<ckobj>. The function is intended to be called
8962 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8964 In this call, I<entersubop> is a pointer to the C<entersub> op,
8965 which may be replaced by the check function, and I<namegv> is a GV
8966 supplying the name that should be used by the check function to refer
8967 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8968 It is permitted to apply the check function in non-standard situations,
8969 such as to a call to a different subroutine or to a method call.
8971 The current setting for a particular CV can be retrieved by
8972 L</cv_get_call_checker>.
8978 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8980 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8981 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8982 if (SvMAGICAL((SV*)cv))
8983 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8986 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8987 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8988 if (callmg->mg_flags & MGf_REFCOUNTED) {
8989 SvREFCNT_dec(callmg->mg_obj);
8990 callmg->mg_flags &= ~MGf_REFCOUNTED;
8992 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8993 callmg->mg_obj = ckobj;
8994 if (ckobj != (SV*)cv) {
8995 SvREFCNT_inc_simple_void_NN(ckobj);
8996 callmg->mg_flags |= MGf_REFCOUNTED;
9002 Perl_ck_subr(pTHX_ OP *o)
9008 PERL_ARGS_ASSERT_CK_SUBR;
9010 aop = cUNOPx(o)->op_first;
9011 if (!aop->op_sibling)
9012 aop = cUNOPx(aop)->op_first;
9013 aop = aop->op_sibling;
9014 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9015 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9016 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9018 o->op_private |= OPpENTERSUB_HASTARG;
9019 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9020 if (PERLDB_SUB && PL_curstash != PL_debstash)
9021 o->op_private |= OPpENTERSUB_DB;
9022 if (cvop->op_type == OP_RV2CV) {
9023 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9025 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9026 if (aop->op_type == OP_CONST)
9027 aop->op_private &= ~OPpCONST_STRICT;
9028 else if (aop->op_type == OP_LIST) {
9029 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9030 if (sib && sib->op_type == OP_CONST)
9031 sib->op_private &= ~OPpCONST_STRICT;
9036 return ck_entersub_args_list(o);
9038 Perl_call_checker ckfun;
9040 cv_get_call_checker(cv, &ckfun, &ckobj);
9041 return ckfun(aTHX_ o, namegv, ckobj);
9046 Perl_ck_svconst(pTHX_ OP *o)
9048 PERL_ARGS_ASSERT_CK_SVCONST;
9049 PERL_UNUSED_CONTEXT;
9050 SvREADONLY_on(cSVOPo->op_sv);
9055 Perl_ck_chdir(pTHX_ OP *o)
9057 PERL_ARGS_ASSERT_CK_CHDIR;
9058 if (o->op_flags & OPf_KIDS) {
9059 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9061 if (kid && kid->op_type == OP_CONST &&
9062 (kid->op_private & OPpCONST_BARE))
9064 o->op_flags |= OPf_SPECIAL;
9065 kid->op_private &= ~OPpCONST_STRICT;
9072 Perl_ck_trunc(pTHX_ OP *o)
9074 PERL_ARGS_ASSERT_CK_TRUNC;
9076 if (o->op_flags & OPf_KIDS) {
9077 SVOP *kid = (SVOP*)cUNOPo->op_first;
9079 if (kid->op_type == OP_NULL)
9080 kid = (SVOP*)kid->op_sibling;
9081 if (kid && kid->op_type == OP_CONST &&
9082 (kid->op_private & OPpCONST_BARE))
9084 o->op_flags |= OPf_SPECIAL;
9085 kid->op_private &= ~OPpCONST_STRICT;
9092 Perl_ck_unpack(pTHX_ OP *o)
9094 OP *kid = cLISTOPo->op_first;
9096 PERL_ARGS_ASSERT_CK_UNPACK;
9098 if (kid->op_sibling) {
9099 kid = kid->op_sibling;
9100 if (!kid->op_sibling)
9101 kid->op_sibling = newDEFSVOP();
9107 Perl_ck_substr(pTHX_ OP *o)
9109 PERL_ARGS_ASSERT_CK_SUBSTR;
9112 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9113 OP *kid = cLISTOPo->op_first;
9115 if (kid->op_type == OP_NULL)
9116 kid = kid->op_sibling;
9118 kid->op_flags |= OPf_MOD;
9125 Perl_ck_push(pTHX_ OP *o)
9128 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9132 PERL_ARGS_ASSERT_CK_PUSH;
9134 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9136 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9139 /* If not array or array deref, wrap it with an array deref.
9140 * For OP_CONST, we only wrap arrayrefs */
9142 if ( ( cursor->op_type != OP_PADAV
9143 && cursor->op_type != OP_RV2AV
9144 && cursor->op_type != OP_CONST
9147 ( cursor->op_type == OP_CONST
9148 && SvROK(cSVOPx_sv(cursor))
9149 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9152 proxy = newAVREF(cursor);
9153 if ( cursor == kid ) {
9154 cLISTOPx(o)->op_first = proxy;
9157 cLISTOPx(kid)->op_sibling = proxy;
9159 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9160 cLISTOPx(cursor)->op_sibling = NULL;
9167 Perl_ck_each(pTHX_ OP *o)
9170 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9171 const unsigned orig_type = o->op_type;
9172 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9173 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9174 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9175 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9177 PERL_ARGS_ASSERT_CK_EACH;
9180 switch (kid->op_type) {
9186 CHANGE_TYPE(o, array_type);
9189 if (kid->op_private == OPpCONST_BARE)
9190 /* we let ck_fun treat as hash */
9193 CHANGE_TYPE(o, ref_type);
9196 /* if treating as a reference, defer additional checks to runtime */
9197 return o->op_type == ref_type ? o : ck_fun(o);
9200 /* caller is supposed to assign the return to the
9201 container of the rep_op var */
9203 S_opt_scalarhv(pTHX_ OP *rep_op) {
9207 PERL_ARGS_ASSERT_OPT_SCALARHV;
9209 NewOp(1101, unop, 1, UNOP);
9210 unop->op_type = (OPCODE)OP_BOOLKEYS;
9211 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9212 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9213 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9214 unop->op_first = rep_op;
9215 unop->op_next = rep_op->op_next;
9216 rep_op->op_next = (OP*)unop;
9217 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9218 unop->op_sibling = rep_op->op_sibling;
9219 rep_op->op_sibling = NULL;
9220 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9221 if (rep_op->op_type == OP_PADHV) {
9222 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9223 rep_op->op_flags |= OPf_WANT_LIST;
9228 /* Checks if o acts as an in-place operator on an array. oright points to the
9229 * beginning of the right-hand side. Returns the left-hand side of the
9230 * assignment if o acts in-place, or NULL otherwise. */
9233 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9237 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9240 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9241 || oright->op_next != o
9242 || (oright->op_private & OPpLVAL_INTRO)
9246 /* o2 follows the chain of op_nexts through the LHS of the
9247 * assign (if any) to the aassign op itself */
9249 if (!o2 || o2->op_type != OP_NULL)
9252 if (!o2 || o2->op_type != OP_PUSHMARK)
9255 if (o2 && o2->op_type == OP_GV)
9258 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9259 || (o2->op_private & OPpLVAL_INTRO)
9264 if (!o2 || o2->op_type != OP_NULL)
9267 if (!o2 || o2->op_type != OP_AASSIGN
9268 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9271 /* check that the sort is the first arg on RHS of assign */
9273 o2 = cUNOPx(o2)->op_first;
9274 if (!o2 || o2->op_type != OP_NULL)
9276 o2 = cUNOPx(o2)->op_first;
9277 if (!o2 || o2->op_type != OP_PUSHMARK)
9279 if (o2->op_sibling != o)
9282 /* check the array is the same on both sides */
9283 if (oleft->op_type == OP_RV2AV) {
9284 if (oright->op_type != OP_RV2AV
9285 || !cUNOPx(oright)->op_first
9286 || cUNOPx(oright)->op_first->op_type != OP_GV
9287 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9288 cGVOPx_gv(cUNOPx(oright)->op_first)
9292 else if (oright->op_type != OP_PADAV
9293 || oright->op_targ != oleft->op_targ
9300 /* A peephole optimizer. We visit the ops in the order they're to execute.
9301 * See the comments at the top of this file for more details about when
9302 * peep() is called */
9305 Perl_rpeep(pTHX_ register OP *o)
9308 register OP* oldop = NULL;
9310 if (!o || o->op_opt)
9314 SAVEVPTR(PL_curcop);
9315 for (; o; o = o->op_next) {
9318 /* By default, this op has now been optimised. A couple of cases below
9319 clear this again. */
9322 switch (o->op_type) {
9324 PL_curcop = ((COP*)o); /* for warnings */
9327 PL_curcop = ((COP*)o); /* for warnings */
9329 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9330 to carry two labels. For now, take the easier option, and skip
9331 this optimisation if the first NEXTSTATE has a label. */
9332 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9333 OP *nextop = o->op_next;
9334 while (nextop && nextop->op_type == OP_NULL)
9335 nextop = nextop->op_next;
9337 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9338 COP *firstcop = (COP *)o;
9339 COP *secondcop = (COP *)nextop;
9340 /* We want the COP pointed to by o (and anything else) to
9341 become the next COP down the line. */
9344 firstcop->op_next = secondcop->op_next;
9346 /* Now steal all its pointers, and duplicate the other
9348 firstcop->cop_line = secondcop->cop_line;
9350 firstcop->cop_stashpv = secondcop->cop_stashpv;
9351 firstcop->cop_file = secondcop->cop_file;
9353 firstcop->cop_stash = secondcop->cop_stash;
9354 firstcop->cop_filegv = secondcop->cop_filegv;
9356 firstcop->cop_hints = secondcop->cop_hints;
9357 firstcop->cop_seq = secondcop->cop_seq;
9358 firstcop->cop_warnings = secondcop->cop_warnings;
9359 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9362 secondcop->cop_stashpv = NULL;
9363 secondcop->cop_file = NULL;
9365 secondcop->cop_stash = NULL;
9366 secondcop->cop_filegv = NULL;
9368 secondcop->cop_warnings = NULL;
9369 secondcop->cop_hints_hash = NULL;
9371 /* If we use op_null(), and hence leave an ex-COP, some
9372 warnings are misreported. For example, the compile-time
9373 error in 'use strict; no strict refs;' */
9374 secondcop->op_type = OP_NULL;
9375 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9381 if (cSVOPo->op_private & OPpCONST_STRICT)
9382 no_bareword_allowed(o);
9385 case OP_METHOD_NAMED:
9386 /* Relocate sv to the pad for thread safety.
9387 * Despite being a "constant", the SV is written to,
9388 * for reference counts, sv_upgrade() etc. */
9390 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9391 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9392 /* If op_sv is already a PADTMP then it is being used by
9393 * some pad, so make a copy. */
9394 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9395 SvREADONLY_on(PAD_SVl(ix));
9396 SvREFCNT_dec(cSVOPo->op_sv);
9398 else if (o->op_type != OP_METHOD_NAMED
9399 && cSVOPo->op_sv == &PL_sv_undef) {
9400 /* PL_sv_undef is hack - it's unsafe to store it in the
9401 AV that is the pad, because av_fetch treats values of
9402 PL_sv_undef as a "free" AV entry and will merrily
9403 replace them with a new SV, causing pad_alloc to think
9404 that this pad slot is free. (When, clearly, it is not)
9406 SvOK_off(PAD_SVl(ix));
9407 SvPADTMP_on(PAD_SVl(ix));
9408 SvREADONLY_on(PAD_SVl(ix));
9411 SvREFCNT_dec(PAD_SVl(ix));
9412 SvPADTMP_on(cSVOPo->op_sv);
9413 PAD_SETSV(ix, cSVOPo->op_sv);
9414 /* XXX I don't know how this isn't readonly already. */
9415 SvREADONLY_on(PAD_SVl(ix));
9417 cSVOPo->op_sv = NULL;
9424 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9425 if (o->op_next->op_private & OPpTARGET_MY) {
9426 if (o->op_flags & OPf_STACKED) /* chained concats */
9427 break; /* ignore_optimization */
9429 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9430 o->op_targ = o->op_next->op_targ;
9431 o->op_next->op_targ = 0;
9432 o->op_private |= OPpTARGET_MY;
9435 op_null(o->op_next);
9439 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9440 break; /* Scalar stub must produce undef. List stub is noop */
9444 if (o->op_targ == OP_NEXTSTATE
9445 || o->op_targ == OP_DBSTATE)
9447 PL_curcop = ((COP*)o);
9449 /* XXX: We avoid setting op_seq here to prevent later calls
9450 to rpeep() from mistakenly concluding that optimisation
9451 has already occurred. This doesn't fix the real problem,
9452 though (See 20010220.007). AMS 20010719 */
9453 /* op_seq functionality is now replaced by op_opt */
9460 if (oldop && o->op_next) {
9461 oldop->op_next = o->op_next;
9469 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9470 OP* const pop = (o->op_type == OP_PADAV) ?
9471 o->op_next : o->op_next->op_next;
9473 if (pop && pop->op_type == OP_CONST &&
9474 ((PL_op = pop->op_next)) &&
9475 pop->op_next->op_type == OP_AELEM &&
9476 !(pop->op_next->op_private &
9477 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9478 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9483 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9484 no_bareword_allowed(pop);
9485 if (o->op_type == OP_GV)
9486 op_null(o->op_next);
9487 op_null(pop->op_next);
9489 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9490 o->op_next = pop->op_next->op_next;
9491 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9492 o->op_private = (U8)i;
9493 if (o->op_type == OP_GV) {
9498 o->op_flags |= OPf_SPECIAL;
9499 o->op_type = OP_AELEMFAST;
9504 if (o->op_next->op_type == OP_RV2SV) {
9505 if (!(o->op_next->op_private & OPpDEREF)) {
9506 op_null(o->op_next);
9507 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9509 o->op_next = o->op_next->op_next;
9510 o->op_type = OP_GVSV;
9511 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9514 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9515 GV * const gv = cGVOPo_gv;
9516 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9517 /* XXX could check prototype here instead of just carping */
9518 SV * const sv = sv_newmortal();
9519 gv_efullname3(sv, gv, NULL);
9520 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9521 "%"SVf"() called too early to check prototype",
9525 else if (o->op_next->op_type == OP_READLINE
9526 && o->op_next->op_next->op_type == OP_CONCAT
9527 && (o->op_next->op_next->op_flags & OPf_STACKED))
9529 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9530 o->op_type = OP_RCATLINE;
9531 o->op_flags |= OPf_STACKED;
9532 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9533 op_null(o->op_next->op_next);
9534 op_null(o->op_next);
9544 fop = cUNOP->op_first;
9552 fop = cLOGOP->op_first;
9553 sop = fop->op_sibling;
9554 while (cLOGOP->op_other->op_type == OP_NULL)
9555 cLOGOP->op_other = cLOGOP->op_other->op_next;
9556 CALL_RPEEP(cLOGOP->op_other);
9560 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9562 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9567 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9568 while (nop && nop->op_next) {
9569 switch (nop->op_next->op_type) {
9574 lop = nop = nop->op_next;
9585 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9586 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9587 cLOGOP->op_first = opt_scalarhv(fop);
9588 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9589 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9605 while (cLOGOP->op_other->op_type == OP_NULL)
9606 cLOGOP->op_other = cLOGOP->op_other->op_next;
9607 CALL_RPEEP(cLOGOP->op_other);
9612 while (cLOOP->op_redoop->op_type == OP_NULL)
9613 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9614 CALL_RPEEP(cLOOP->op_redoop);
9615 while (cLOOP->op_nextop->op_type == OP_NULL)
9616 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9617 CALL_RPEEP(cLOOP->op_nextop);
9618 while (cLOOP->op_lastop->op_type == OP_NULL)
9619 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9620 CALL_RPEEP(cLOOP->op_lastop);
9624 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9625 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9626 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9627 cPMOP->op_pmstashstartu.op_pmreplstart
9628 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9629 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9633 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9634 && ckWARN(WARN_SYNTAX))
9636 if (o->op_next->op_sibling) {
9637 const OPCODE type = o->op_next->op_sibling->op_type;
9638 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9639 const line_t oldline = CopLINE(PL_curcop);
9640 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9641 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9642 "Statement unlikely to be reached");
9643 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9644 "\t(Maybe you meant system() when you said exec()?)\n");
9645 CopLINE_set(PL_curcop, oldline);
9656 const char *key = NULL;
9659 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9662 /* Make the CONST have a shared SV */
9663 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9664 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9665 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9666 key = SvPV_const(sv, keylen);
9667 lexname = newSVpvn_share(key,
9668 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9674 if ((o->op_private & (OPpLVAL_INTRO)))
9677 rop = (UNOP*)((BINOP*)o)->op_first;
9678 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9680 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9681 if (!SvPAD_TYPED(lexname))
9683 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9684 if (!fields || !GvHV(*fields))
9686 key = SvPV_const(*svp, keylen);
9687 if (!hv_fetch(GvHV(*fields), key,
9688 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9690 Perl_croak(aTHX_ "No such class field \"%s\" "
9691 "in variable %s of type %s",
9692 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9705 SVOP *first_key_op, *key_op;
9707 if ((o->op_private & (OPpLVAL_INTRO))
9708 /* I bet there's always a pushmark... */
9709 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9710 /* hmmm, no optimization if list contains only one key. */
9712 rop = (UNOP*)((LISTOP*)o)->op_last;
9713 if (rop->op_type != OP_RV2HV)
9715 if (rop->op_first->op_type == OP_PADSV)
9716 /* @$hash{qw(keys here)} */
9717 rop = (UNOP*)rop->op_first;
9719 /* @{$hash}{qw(keys here)} */
9720 if (rop->op_first->op_type == OP_SCOPE
9721 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9723 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9729 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9730 if (!SvPAD_TYPED(lexname))
9732 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9733 if (!fields || !GvHV(*fields))
9735 /* Again guessing that the pushmark can be jumped over.... */
9736 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9737 ->op_first->op_sibling;
9738 for (key_op = first_key_op; key_op;
9739 key_op = (SVOP*)key_op->op_sibling) {
9740 if (key_op->op_type != OP_CONST)
9742 svp = cSVOPx_svp(key_op);
9743 key = SvPV_const(*svp, keylen);
9744 if (!hv_fetch(GvHV(*fields), key,
9745 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9747 Perl_croak(aTHX_ "No such class field \"%s\" "
9748 "in variable %s of type %s",
9749 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9758 && ( oldop->op_type == OP_AELEM
9759 || oldop->op_type == OP_PADSV
9760 || oldop->op_type == OP_RV2SV
9761 || oldop->op_type == OP_RV2GV
9762 || oldop->op_type == OP_HELEM
9764 && (oldop->op_private & OPpDEREF)
9766 o->op_private |= OPpDEREFed;
9770 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9774 /* check that RHS of sort is a single plain array */
9775 OP *oright = cUNOPo->op_first;
9776 if (!oright || oright->op_type != OP_PUSHMARK)
9779 /* reverse sort ... can be optimised. */
9780 if (!cUNOPo->op_sibling) {
9781 /* Nothing follows us on the list. */
9782 OP * const reverse = o->op_next;
9784 if (reverse->op_type == OP_REVERSE &&
9785 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9786 OP * const pushmark = cUNOPx(reverse)->op_first;
9787 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9788 && (cUNOPx(pushmark)->op_sibling == o)) {
9789 /* reverse -> pushmark -> sort */
9790 o->op_private |= OPpSORT_REVERSE;
9792 pushmark->op_next = oright->op_next;
9798 /* make @a = sort @a act in-place */
9800 oright = cUNOPx(oright)->op_sibling;
9803 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9804 oright = cUNOPx(oright)->op_sibling;
9807 oleft = is_inplace_av(o, oright);
9811 /* transfer MODishness etc from LHS arg to RHS arg */
9812 oright->op_flags = oleft->op_flags;
9813 o->op_private |= OPpSORT_INPLACE;
9815 /* excise push->gv->rv2av->null->aassign */
9816 o2 = o->op_next->op_next;
9817 op_null(o2); /* PUSHMARK */
9819 if (o2->op_type == OP_GV) {
9820 op_null(o2); /* GV */
9823 op_null(o2); /* RV2AV or PADAV */
9824 o2 = o2->op_next->op_next;
9825 op_null(o2); /* AASSIGN */
9827 o->op_next = o2->op_next;
9833 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9836 LISTOP *enter, *exlist;
9838 /* @a = reverse @a */
9839 if ((oright = cLISTOPo->op_first)
9840 && (oright->op_type == OP_PUSHMARK)
9841 && (oright = oright->op_sibling)
9842 && (oleft = is_inplace_av(o, oright))) {
9845 /* transfer MODishness etc from LHS arg to RHS arg */
9846 oright->op_flags = oleft->op_flags;
9847 o->op_private |= OPpREVERSE_INPLACE;
9849 /* excise push->gv->rv2av->null->aassign */
9850 o2 = o->op_next->op_next;
9851 op_null(o2); /* PUSHMARK */
9853 if (o2->op_type == OP_GV) {
9854 op_null(o2); /* GV */
9857 op_null(o2); /* RV2AV or PADAV */
9858 o2 = o2->op_next->op_next;
9859 op_null(o2); /* AASSIGN */
9861 o->op_next = o2->op_next;
9865 enter = (LISTOP *) o->op_next;
9868 if (enter->op_type == OP_NULL) {
9869 enter = (LISTOP *) enter->op_next;
9873 /* for $a (...) will have OP_GV then OP_RV2GV here.
9874 for (...) just has an OP_GV. */
9875 if (enter->op_type == OP_GV) {
9876 gvop = (OP *) enter;
9877 enter = (LISTOP *) enter->op_next;
9880 if (enter->op_type == OP_RV2GV) {
9881 enter = (LISTOP *) enter->op_next;
9887 if (enter->op_type != OP_ENTERITER)
9890 iter = enter->op_next;
9891 if (!iter || iter->op_type != OP_ITER)
9894 expushmark = enter->op_first;
9895 if (!expushmark || expushmark->op_type != OP_NULL
9896 || expushmark->op_targ != OP_PUSHMARK)
9899 exlist = (LISTOP *) expushmark->op_sibling;
9900 if (!exlist || exlist->op_type != OP_NULL
9901 || exlist->op_targ != OP_LIST)
9904 if (exlist->op_last != o) {
9905 /* Mmm. Was expecting to point back to this op. */
9908 theirmark = exlist->op_first;
9909 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9912 if (theirmark->op_sibling != o) {
9913 /* There's something between the mark and the reverse, eg
9914 for (1, reverse (...))
9919 ourmark = ((LISTOP *)o)->op_first;
9920 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9923 ourlast = ((LISTOP *)o)->op_last;
9924 if (!ourlast || ourlast->op_next != o)
9927 rv2av = ourmark->op_sibling;
9928 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9929 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9930 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9931 /* We're just reversing a single array. */
9932 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9933 enter->op_flags |= OPf_STACKED;
9936 /* We don't have control over who points to theirmark, so sacrifice
9938 theirmark->op_next = ourmark->op_next;
9939 theirmark->op_flags = ourmark->op_flags;
9940 ourlast->op_next = gvop ? gvop : (OP *) enter;
9943 enter->op_private |= OPpITER_REVERSED;
9944 iter->op_private |= OPpITER_REVERSED;
9951 UNOP *refgen, *rv2cv;
9954 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9957 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9960 rv2gv = ((BINOP *)o)->op_last;
9961 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9964 refgen = (UNOP *)((BINOP *)o)->op_first;
9966 if (!refgen || refgen->op_type != OP_REFGEN)
9969 exlist = (LISTOP *)refgen->op_first;
9970 if (!exlist || exlist->op_type != OP_NULL
9971 || exlist->op_targ != OP_LIST)
9974 if (exlist->op_first->op_type != OP_PUSHMARK)
9977 rv2cv = (UNOP*)exlist->op_last;
9979 if (rv2cv->op_type != OP_RV2CV)
9982 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9983 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9984 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9986 o->op_private |= OPpASSIGN_CV_TO_GV;
9987 rv2gv->op_private |= OPpDONT_INIT_GV;
9988 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9996 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9997 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10002 Perl_cpeep_t cpeep =
10003 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10005 cpeep(aTHX_ o, oldop);
10016 Perl_peep(pTHX_ register OP *o)
10022 =head1 Custom Operators
10024 =for apidoc Ao||custom_op_xop
10025 Return the XOP structure for a given custom op. This function should be
10026 considered internal to OP_NAME and the other access macros: use them instead.
10032 Perl_custom_op_xop(pTHX_ const OP *o)
10038 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10040 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10041 assert(o->op_type == OP_CUSTOM);
10043 /* This is wrong. It assumes a function pointer can be cast to IV,
10044 * which isn't guaranteed, but this is what the old custom OP code
10045 * did. In principle it should be safer to Copy the bytes of the
10046 * pointer into a PV: since the new interface is hidden behind
10047 * functions, this can be changed later if necessary. */
10048 /* Change custom_op_xop if this ever happens */
10049 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10052 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10054 /* assume noone will have just registered a desc */
10055 if (!he && PL_custom_op_names &&
10056 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10061 /* XXX does all this need to be shared mem? */
10062 Newxz(xop, 1, XOP);
10063 pv = SvPV(HeVAL(he), l);
10064 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10065 if (PL_custom_op_descs &&
10066 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10068 pv = SvPV(HeVAL(he), l);
10069 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10071 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10075 if (!he) return &xop_null;
10077 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10082 =for apidoc Ao||custom_op_register
10083 Register a custom op. See L<perlguts/"Custom Operators">.
10089 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10093 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10095 /* see the comment in custom_op_xop */
10096 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10098 if (!PL_custom_ops)
10099 PL_custom_ops = newHV();
10101 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10102 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10107 /* Efficient sub that returns a constant scalar value. */
10109 const_sv_xsub(pTHX_ CV* cv)
10113 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10117 /* diag_listed_as: SKIPME */
10118 Perl_croak(aTHX_ "usage: %s::%s()",
10119 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10132 * c-indentation-style: bsd
10133 * c-basic-offset: 4
10134 * indent-tabs-mode: t
10137 * ex: set ts=8 sts=4 sw=4 noet: