4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 /* if (o->op_madprop && o->op_madprop->mad_next)
552 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
553 "modification of a read only value" for a reason I can't fathom why.
554 It's the "" stringification of $_, where $_ was set to '' in a foreach
555 loop, but it defies simplification into a small test case.
556 However, commenting them out has caused ext/List/Util/t/weak.t to fail
559 mad_free(o->op_madprop);
565 switch (o->op_type) {
566 case OP_NULL: /* Was holding old type, if any. */
567 if (PL_madskills && o->op_targ != OP_NULL) {
568 o->op_type = (Optype)o->op_targ;
573 case OP_ENTEREVAL: /* Was holding hints. */
577 if (!(o->op_flags & OPf_REF)
578 || (PL_check[o->op_type] != Perl_ck_ftst))
584 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
585 /* not an OP_PADAV replacement */
586 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
591 /* It's possible during global destruction that the GV is freed
592 before the optree. Whilst the SvREFCNT_inc is happy to bump from
593 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
594 will trigger an assertion failure, because the entry to sv_clear
595 checks that the scalar is not already freed. A check of for
596 !SvIS_FREED(gv) turns out to be invalid, because during global
597 destruction the reference count can be forced down to zero
598 (with SVf_BREAK set). In which case raising to 1 and then
599 dropping to 0 triggers cleanup before it should happen. I
600 *think* that this might actually be a general, systematic,
601 weakness of the whole idea of SVf_BREAK, in that code *is*
602 allowed to raise and lower references during global destruction,
603 so any *valid* code that happens to do this during global
604 destruction might well trigger premature cleanup. */
605 bool still_valid = gv && SvREFCNT(gv);
608 SvREFCNT_inc_simple_void(gv);
610 if (cPADOPo->op_padix > 0) {
611 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
612 * may still exist on the pad */
613 pad_swipe(cPADOPo->op_padix, TRUE);
614 cPADOPo->op_padix = 0;
617 SvREFCNT_dec(cSVOPo->op_sv);
618 cSVOPo->op_sv = NULL;
621 int try_downgrade = SvREFCNT(gv) == 2;
624 gv_try_downgrade(gv);
628 case OP_METHOD_NAMED:
631 SvREFCNT_dec(cSVOPo->op_sv);
632 cSVOPo->op_sv = NULL;
635 Even if op_clear does a pad_free for the target of the op,
636 pad_free doesn't actually remove the sv that exists in the pad;
637 instead it lives on. This results in that it could be reused as
638 a target later on when the pad was reallocated.
641 pad_swipe(o->op_targ,1);
650 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
655 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
657 if (cPADOPo->op_padix > 0) {
658 pad_swipe(cPADOPo->op_padix, TRUE);
659 cPADOPo->op_padix = 0;
662 SvREFCNT_dec(cSVOPo->op_sv);
663 cSVOPo->op_sv = NULL;
667 PerlMemShared_free(cPVOPo->op_pv);
668 cPVOPo->op_pv = NULL;
672 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
676 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
677 /* No GvIN_PAD_off here, because other references may still
678 * exist on the pad */
679 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
682 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
688 forget_pmop(cPMOPo, 1);
689 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
690 /* we use the same protection as the "SAFE" version of the PM_ macros
691 * here since sv_clean_all might release some PMOPs
692 * after PL_regex_padav has been cleared
693 * and the clearing of PL_regex_padav needs to
694 * happen before sv_clean_all
697 if(PL_regex_pad) { /* We could be in destruction */
698 const IV offset = (cPMOPo)->op_pmoffset;
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PL_regex_pad[offset] = &PL_sv_undef;
701 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
705 ReREFCNT_dec(PM_GETRE(cPMOPo));
706 PM_SETRE(cPMOPo, NULL);
712 if (o->op_targ > 0) {
713 pad_free(o->op_targ);
719 S_cop_free(pTHX_ COP* cop)
721 PERL_ARGS_ASSERT_COP_FREE;
725 if (! specialWARN(cop->cop_warnings))
726 PerlMemShared_free(cop->cop_warnings);
727 cophh_free(CopHINTHASH_get(cop));
731 S_forget_pmop(pTHX_ PMOP *const o
737 HV * const pmstash = PmopSTASH(o);
739 PERL_ARGS_ASSERT_FORGET_PMOP;
741 if (pmstash && !SvIS_FREED(pmstash)) {
742 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
744 PMOP **const array = (PMOP**) mg->mg_ptr;
745 U32 count = mg->mg_len / sizeof(PMOP**);
750 /* Found it. Move the entry at the end to overwrite it. */
751 array[i] = array[--count];
752 mg->mg_len = count * sizeof(PMOP**);
753 /* Could realloc smaller at this point always, but probably
754 not worth it. Probably worth free()ing if we're the
757 Safefree(mg->mg_ptr);
774 S_find_and_forget_pmops(pTHX_ OP *o)
776 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
778 if (o->op_flags & OPf_KIDS) {
779 OP *kid = cUNOPo->op_first;
781 switch (kid->op_type) {
786 forget_pmop((PMOP*)kid, 0);
788 find_and_forget_pmops(kid);
789 kid = kid->op_sibling;
795 Perl_op_null(pTHX_ OP *o)
799 PERL_ARGS_ASSERT_OP_NULL;
801 if (o->op_type == OP_NULL)
805 o->op_targ = o->op_type;
806 o->op_type = OP_NULL;
807 o->op_ppaddr = PL_ppaddr[OP_NULL];
811 Perl_op_refcnt_lock(pTHX)
819 Perl_op_refcnt_unlock(pTHX)
826 /* Contextualizers */
829 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
831 Applies a syntactic context to an op tree representing an expression.
832 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
833 or C<G_VOID> to specify the context to apply. The modified op tree
840 Perl_op_contextualize(pTHX_ OP *o, I32 context)
842 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
844 case G_SCALAR: return scalar(o);
845 case G_ARRAY: return list(o);
846 case G_VOID: return scalarvoid(o);
848 Perl_croak(aTHX_ "panic: op_contextualize bad context");
854 =head1 Optree Manipulation Functions
856 =for apidoc Am|OP*|op_linklist|OP *o
857 This function is the implementation of the L</LINKLIST> macro. It should
858 not be called directly.
864 Perl_op_linklist(pTHX_ OP *o)
868 PERL_ARGS_ASSERT_OP_LINKLIST;
873 /* establish postfix order */
874 first = cUNOPo->op_first;
877 o->op_next = LINKLIST(first);
880 if (kid->op_sibling) {
881 kid->op_next = LINKLIST(kid->op_sibling);
882 kid = kid->op_sibling;
896 S_scalarkids(pTHX_ OP *o)
898 if (o && o->op_flags & OPf_KIDS) {
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 S_scalarboolean(pTHX_ OP *o)
911 PERL_ARGS_ASSERT_SCALARBOOLEAN;
913 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
914 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
915 if (ckWARN(WARN_SYNTAX)) {
916 const line_t oldline = CopLINE(PL_curcop);
918 if (PL_parser && PL_parser->copline != NOLINE)
919 CopLINE_set(PL_curcop, PL_parser->copline);
920 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
921 CopLINE_set(PL_curcop, oldline);
928 Perl_scalar(pTHX_ OP *o)
933 /* assumes no premature commitment */
934 if (!o || (PL_parser && PL_parser->error_count)
935 || (o->op_flags & OPf_WANT)
936 || o->op_type == OP_RETURN)
941 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
943 switch (o->op_type) {
945 scalar(cBINOPo->op_first);
950 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
960 if (o->op_flags & OPf_KIDS) {
961 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
967 kid = cLISTOPo->op_first;
969 kid = kid->op_sibling;
972 OP *sib = kid->op_sibling;
973 if (sib && kid->op_type != OP_LEAVEWHEN) {
974 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
984 PL_curcop = &PL_compiling;
989 kid = cLISTOPo->op_first;
992 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
999 Perl_scalarvoid(pTHX_ OP *o)
1003 const char* useless = NULL;
1007 PERL_ARGS_ASSERT_SCALARVOID;
1009 /* trailing mad null ops don't count as "there" for void processing */
1011 o->op_type != OP_NULL &&
1013 o->op_sibling->op_type == OP_NULL)
1016 for (sib = o->op_sibling;
1017 sib && sib->op_type == OP_NULL;
1018 sib = sib->op_sibling) ;
1024 if (o->op_type == OP_NEXTSTATE
1025 || o->op_type == OP_DBSTATE
1026 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1027 || o->op_targ == OP_DBSTATE)))
1028 PL_curcop = (COP*)o; /* for warning below */
1030 /* assumes no premature commitment */
1031 want = o->op_flags & OPf_WANT;
1032 if ((want && want != OPf_WANT_SCALAR)
1033 || (PL_parser && PL_parser->error_count)
1034 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1039 if ((o->op_private & OPpTARGET_MY)
1040 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1042 return scalar(o); /* As if inside SASSIGN */
1045 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1047 switch (o->op_type) {
1049 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1053 if (o->op_flags & OPf_STACKED)
1057 if (o->op_private == 4)
1100 case OP_GETSOCKNAME:
1101 case OP_GETPEERNAME:
1106 case OP_GETPRIORITY:
1130 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1131 /* Otherwise it's "Useless use of grep iterator" */
1132 useless = OP_DESC(o);
1136 kid = cLISTOPo->op_first;
1137 if (kid && kid->op_type == OP_PUSHRE
1139 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1141 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1143 useless = OP_DESC(o);
1147 kid = cUNOPo->op_first;
1148 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1149 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1152 useless = "negative pattern binding (!~)";
1156 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1157 useless = "non-destructive substitution (s///r)";
1161 useless = "non-destructive transliteration (tr///r)";
1168 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1169 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1170 useless = "a variable";
1175 if (cSVOPo->op_private & OPpCONST_STRICT)
1176 no_bareword_allowed(o);
1178 if (ckWARN(WARN_VOID)) {
1180 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1181 "a constant (%"SVf")", sv));
1182 useless = SvPV_nolen(msv);
1185 useless = "a constant (undef)";
1186 if (o->op_private & OPpCONST_ARYBASE)
1188 /* don't warn on optimised away booleans, eg
1189 * use constant Foo, 5; Foo || print; */
1190 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1192 /* the constants 0 and 1 are permitted as they are
1193 conventionally used as dummies in constructs like
1194 1 while some_condition_with_side_effects; */
1195 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1197 else if (SvPOK(sv)) {
1198 /* perl4's way of mixing documentation and code
1199 (before the invention of POD) was based on a
1200 trick to mix nroff and perl code. The trick was
1201 built upon these three nroff macros being used in
1202 void context. The pink camel has the details in
1203 the script wrapman near page 319. */
1204 const char * const maybe_macro = SvPVX_const(sv);
1205 if (strnEQ(maybe_macro, "di", 2) ||
1206 strnEQ(maybe_macro, "ds", 2) ||
1207 strnEQ(maybe_macro, "ig", 2))
1212 op_null(o); /* don't execute or even remember it */
1216 o->op_type = OP_PREINC; /* pre-increment is faster */
1217 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1221 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1222 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1226 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1227 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1231 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1232 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1237 kid = cLOGOPo->op_first;
1238 if (kid->op_type == OP_NOT
1239 && (kid->op_flags & OPf_KIDS)
1241 if (o->op_type == OP_AND) {
1243 o->op_ppaddr = PL_ppaddr[OP_OR];
1245 o->op_type = OP_AND;
1246 o->op_ppaddr = PL_ppaddr[OP_AND];
1255 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1260 if (o->op_flags & OPf_STACKED)
1267 if (!(o->op_flags & OPf_KIDS))
1278 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1288 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1293 S_listkids(pTHX_ OP *o)
1295 if (o && o->op_flags & OPf_KIDS) {
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1304 Perl_list(pTHX_ OP *o)
1309 /* assumes no premature commitment */
1310 if (!o || (o->op_flags & OPf_WANT)
1311 || (PL_parser && PL_parser->error_count)
1312 || o->op_type == OP_RETURN)
1317 if ((o->op_private & OPpTARGET_MY)
1318 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1320 return o; /* As if inside SASSIGN */
1323 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1325 switch (o->op_type) {
1328 list(cBINOPo->op_first);
1333 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1341 if (!(o->op_flags & OPf_KIDS))
1343 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1344 list(cBINOPo->op_first);
1345 return gen_constant_list(o);
1352 kid = cLISTOPo->op_first;
1354 kid = kid->op_sibling;
1357 OP *sib = kid->op_sibling;
1358 if (sib && kid->op_type != OP_LEAVEWHEN) {
1359 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1369 PL_curcop = &PL_compiling;
1373 kid = cLISTOPo->op_first;
1380 S_scalarseq(pTHX_ OP *o)
1384 const OPCODE type = o->op_type;
1386 if (type == OP_LINESEQ || type == OP_SCOPE ||
1387 type == OP_LEAVE || type == OP_LEAVETRY)
1390 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1391 if (kid->op_sibling) {
1395 PL_curcop = &PL_compiling;
1397 o->op_flags &= ~OPf_PARENS;
1398 if (PL_hints & HINT_BLOCK_SCOPE)
1399 o->op_flags |= OPf_PARENS;
1402 o = newOP(OP_STUB, 0);
1407 S_modkids(pTHX_ OP *o, I32 type)
1409 if (o && o->op_flags & OPf_KIDS) {
1411 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1412 op_lvalue(kid, type);
1418 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1420 Propagate lvalue ("modifiable") context to an op and its children.
1421 I<type> represents the context type, roughly based on the type of op that
1422 would do the modifying, although C<local()> is represented by OP_NULL,
1423 because it has no op type of its own (it is signalled by a flag on
1426 This function detects things that can't be modified, such as C<$x+1>, and
1427 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1428 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1430 It also flags things that need to behave specially in an lvalue context,
1431 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1437 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1441 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1444 if (!o || (PL_parser && PL_parser->error_count))
1447 if ((o->op_private & OPpTARGET_MY)
1448 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1453 switch (o->op_type) {
1459 if (!(o->op_private & OPpCONST_ARYBASE))
1462 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1463 CopARYBASE_set(&PL_compiling,
1464 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1468 SAVECOPARYBASE(&PL_compiling);
1469 CopARYBASE_set(&PL_compiling, 0);
1471 else if (type == OP_REFGEN)
1474 Perl_croak(aTHX_ "That use of $[ is unsupported");
1477 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1481 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1482 !(o->op_flags & OPf_STACKED)) {
1483 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1484 /* The default is to set op_private to the number of children,
1485 which for a UNOP such as RV2CV is always 1. And w're using
1486 the bit for a flag in RV2CV, so we need it clear. */
1487 o->op_private &= ~1;
1488 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1489 assert(cUNOPo->op_first->op_type == OP_NULL);
1490 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1493 else if (o->op_private & OPpENTERSUB_NOMOD)
1495 else { /* lvalue subroutine call */
1496 o->op_private |= OPpLVAL_INTRO;
1497 PL_modcount = RETURN_UNLIMITED_NUMBER;
1498 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1499 /* Backward compatibility mode: */
1500 o->op_private |= OPpENTERSUB_INARGS;
1503 else { /* Compile-time error message: */
1504 OP *kid = cUNOPo->op_first;
1508 if (kid->op_type != OP_PUSHMARK) {
1509 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1511 "panic: unexpected lvalue entersub "
1512 "args: type/targ %ld:%"UVuf,
1513 (long)kid->op_type, (UV)kid->op_targ);
1514 kid = kLISTOP->op_first;
1516 while (kid->op_sibling)
1517 kid = kid->op_sibling;
1518 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1520 if (kid->op_type == OP_METHOD_NAMED
1521 || kid->op_type == OP_METHOD)
1525 NewOp(1101, newop, 1, UNOP);
1526 newop->op_type = OP_RV2CV;
1527 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1528 newop->op_first = NULL;
1529 newop->op_next = (OP*)newop;
1530 kid->op_sibling = (OP*)newop;
1531 newop->op_private |= OPpLVAL_INTRO;
1532 newop->op_private &= ~1;
1536 if (kid->op_type != OP_RV2CV)
1538 "panic: unexpected lvalue entersub "
1539 "entry via type/targ %ld:%"UVuf,
1540 (long)kid->op_type, (UV)kid->op_targ);
1541 kid->op_private |= OPpLVAL_INTRO;
1542 break; /* Postpone until runtime */
1546 kid = kUNOP->op_first;
1547 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1548 kid = kUNOP->op_first;
1549 if (kid->op_type == OP_NULL)
1551 "Unexpected constant lvalue entersub "
1552 "entry via type/targ %ld:%"UVuf,
1553 (long)kid->op_type, (UV)kid->op_targ);
1554 if (kid->op_type != OP_GV) {
1555 /* Restore RV2CV to check lvalueness */
1557 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1558 okid->op_next = kid->op_next;
1559 kid->op_next = okid;
1562 okid->op_next = NULL;
1563 okid->op_type = OP_RV2CV;
1565 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1566 okid->op_private |= OPpLVAL_INTRO;
1567 okid->op_private &= ~1;
1571 cv = GvCV(kGVOP_gv);
1581 /* grep, foreach, subcalls, refgen */
1582 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1584 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1585 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1587 : (o->op_type == OP_ENTERSUB
1588 ? "non-lvalue subroutine call"
1590 type ? PL_op_desc[type] : "local"));
1604 case OP_RIGHT_SHIFT:
1613 if (!(o->op_flags & OPf_STACKED))
1620 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1621 op_lvalue(kid, type);
1626 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1627 PL_modcount = RETURN_UNLIMITED_NUMBER;
1628 return o; /* Treat \(@foo) like ordinary list. */
1632 if (scalar_mod_type(o, type))
1634 ref(cUNOPo->op_first, o->op_type);
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1645 PL_modcount = RETURN_UNLIMITED_NUMBER;
1648 PL_hints |= HINT_BLOCK_SCOPE;
1649 if (type == OP_LEAVESUBLV)
1650 o->op_private |= OPpMAYBE_LVSUB;
1654 ref(cUNOPo->op_first, o->op_type);
1658 PL_hints |= HINT_BLOCK_SCOPE;
1673 PL_modcount = RETURN_UNLIMITED_NUMBER;
1674 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1675 return o; /* Treat \(@foo) like ordinary list. */
1676 if (scalar_mod_type(o, type))
1678 if (type == OP_LEAVESUBLV)
1679 o->op_private |= OPpMAYBE_LVSUB;
1683 if (!type) /* local() */
1684 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1685 PAD_COMPNAME_PV(o->op_targ));
1693 if (type != OP_SASSIGN)
1697 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1702 if (type == OP_LEAVESUBLV)
1703 o->op_private |= OPpMAYBE_LVSUB;
1705 pad_free(o->op_targ);
1706 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1707 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1708 if (o->op_flags & OPf_KIDS)
1709 op_lvalue(cBINOPo->op_first->op_sibling, type);
1714 ref(cBINOPo->op_first, o->op_type);
1715 if (type == OP_ENTERSUB &&
1716 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1717 o->op_private |= OPpLVAL_DEFER;
1718 if (type == OP_LEAVESUBLV)
1719 o->op_private |= OPpMAYBE_LVSUB;
1729 if (o->op_flags & OPf_KIDS)
1730 op_lvalue(cLISTOPo->op_last, type);
1735 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1737 else if (!(o->op_flags & OPf_KIDS))
1739 if (o->op_targ != OP_LIST) {
1740 op_lvalue(cBINOPo->op_first, type);
1746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1747 op_lvalue(kid, type);
1751 if (type != OP_LEAVESUBLV)
1753 break; /* op_lvalue()ing was handled by ck_return() */
1756 /* [20011101.069] File test operators interpret OPf_REF to mean that
1757 their argument is a filehandle; thus \stat(".") should not set
1759 if (type == OP_REFGEN &&
1760 PL_check[o->op_type] == Perl_ck_ftst)
1763 if (type != OP_LEAVESUBLV)
1764 o->op_flags |= OPf_MOD;
1766 if (type == OP_AASSIGN || type == OP_SASSIGN)
1767 o->op_flags |= OPf_SPECIAL|OPf_REF;
1768 else if (!type) { /* local() */
1771 o->op_private |= OPpLVAL_INTRO;
1772 o->op_flags &= ~OPf_SPECIAL;
1773 PL_hints |= HINT_BLOCK_SCOPE;
1778 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1779 "Useless localization of %s", OP_DESC(o));
1782 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1783 && type != OP_LEAVESUBLV)
1784 o->op_flags |= OPf_REF;
1788 /* Do not use this. It will be removed after 5.14. */
1790 Perl_mod(pTHX_ OP *o, I32 type)
1792 return op_lvalue(o,type);
1797 S_scalar_mod_type(const OP *o, I32 type)
1799 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1803 if (o->op_type == OP_RV2GV)
1827 case OP_RIGHT_SHIFT:
1848 S_is_handle_constructor(const OP *o, I32 numargs)
1850 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1852 switch (o->op_type) {
1860 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1873 S_refkids(pTHX_ OP *o, I32 type)
1875 if (o && o->op_flags & OPf_KIDS) {
1877 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1884 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1889 PERL_ARGS_ASSERT_DOREF;
1891 if (!o || (PL_parser && PL_parser->error_count))
1894 switch (o->op_type) {
1896 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1897 !(o->op_flags & OPf_STACKED)) {
1898 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1899 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1900 assert(cUNOPo->op_first->op_type == OP_NULL);
1901 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1902 o->op_flags |= OPf_SPECIAL;
1903 o->op_private &= ~1;
1908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1909 doref(kid, type, set_op_ref);
1912 if (type == OP_DEFINED)
1913 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1914 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1917 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1918 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1919 : type == OP_RV2HV ? OPpDEREF_HV
1921 o->op_flags |= OPf_MOD;
1928 o->op_flags |= OPf_REF;
1931 if (type == OP_DEFINED)
1932 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1933 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1939 o->op_flags |= OPf_REF;
1944 if (!(o->op_flags & OPf_KIDS))
1946 doref(cBINOPo->op_first, type, set_op_ref);
1950 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1951 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1952 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1953 : type == OP_RV2HV ? OPpDEREF_HV
1955 o->op_flags |= OPf_MOD;
1965 if (!(o->op_flags & OPf_KIDS))
1967 doref(cLISTOPo->op_last, type, set_op_ref);
1977 S_dup_attrlist(pTHX_ OP *o)
1982 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1984 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1985 * where the first kid is OP_PUSHMARK and the remaining ones
1986 * are OP_CONST. We need to push the OP_CONST values.
1988 if (o->op_type == OP_CONST)
1989 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1991 else if (o->op_type == OP_NULL)
1995 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1997 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1998 if (o->op_type == OP_CONST)
1999 rop = op_append_elem(OP_LIST, rop,
2000 newSVOP(OP_CONST, o->op_flags,
2001 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2008 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2013 PERL_ARGS_ASSERT_APPLY_ATTRS;
2015 /* fake up C<use attributes $pkg,$rv,@attrs> */
2016 ENTER; /* need to protect against side-effects of 'use' */
2017 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2019 #define ATTRSMODULE "attributes"
2020 #define ATTRSMODULE_PM "attributes.pm"
2023 /* Don't force the C<use> if we don't need it. */
2024 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2025 if (svp && *svp != &PL_sv_undef)
2026 NOOP; /* already in %INC */
2028 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2029 newSVpvs(ATTRSMODULE), NULL);
2032 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2033 newSVpvs(ATTRSMODULE),
2035 op_prepend_elem(OP_LIST,
2036 newSVOP(OP_CONST, 0, stashsv),
2037 op_prepend_elem(OP_LIST,
2038 newSVOP(OP_CONST, 0,
2040 dup_attrlist(attrs))));
2046 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2049 OP *pack, *imop, *arg;
2052 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2057 assert(target->op_type == OP_PADSV ||
2058 target->op_type == OP_PADHV ||
2059 target->op_type == OP_PADAV);
2061 /* Ensure that attributes.pm is loaded. */
2062 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2064 /* Need package name for method call. */
2065 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2067 /* Build up the real arg-list. */
2068 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2070 arg = newOP(OP_PADSV, 0);
2071 arg->op_targ = target->op_targ;
2072 arg = op_prepend_elem(OP_LIST,
2073 newSVOP(OP_CONST, 0, stashsv),
2074 op_prepend_elem(OP_LIST,
2075 newUNOP(OP_REFGEN, 0,
2076 op_lvalue(arg, OP_REFGEN)),
2077 dup_attrlist(attrs)));
2079 /* Fake up a method call to import */
2080 meth = newSVpvs_share("import");
2081 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2082 op_append_elem(OP_LIST,
2083 op_prepend_elem(OP_LIST, pack, list(arg)),
2084 newSVOP(OP_METHOD_NAMED, 0, meth)));
2085 imop->op_private |= OPpENTERSUB_NOMOD;
2087 /* Combine the ops. */
2088 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2092 =notfor apidoc apply_attrs_string
2094 Attempts to apply a list of attributes specified by the C<attrstr> and
2095 C<len> arguments to the subroutine identified by the C<cv> argument which
2096 is expected to be associated with the package identified by the C<stashpv>
2097 argument (see L<attributes>). It gets this wrong, though, in that it
2098 does not correctly identify the boundaries of the individual attribute
2099 specifications within C<attrstr>. This is not really intended for the
2100 public API, but has to be listed here for systems such as AIX which
2101 need an explicit export list for symbols. (It's called from XS code
2102 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2103 to respect attribute syntax properly would be welcome.
2109 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2110 const char *attrstr, STRLEN len)
2114 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2117 len = strlen(attrstr);
2121 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2123 const char * const sstr = attrstr;
2124 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2125 attrs = op_append_elem(OP_LIST, attrs,
2126 newSVOP(OP_CONST, 0,
2127 newSVpvn(sstr, attrstr-sstr)));
2131 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2132 newSVpvs(ATTRSMODULE),
2133 NULL, op_prepend_elem(OP_LIST,
2134 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2135 op_prepend_elem(OP_LIST,
2136 newSVOP(OP_CONST, 0,
2137 newRV(MUTABLE_SV(cv))),
2142 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2147 PERL_ARGS_ASSERT_MY_KID;
2149 if (!o || (PL_parser && PL_parser->error_count))
2153 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2154 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2158 if (type == OP_LIST) {
2160 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2161 my_kid(kid, attrs, imopsp);
2162 } else if (type == OP_UNDEF
2168 } else if (type == OP_RV2SV || /* "our" declaration */
2170 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2171 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2172 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2174 PL_parser->in_my == KEY_our
2176 : PL_parser->in_my == KEY_state ? "state" : "my"));
2178 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2179 PL_parser->in_my = FALSE;
2180 PL_parser->in_my_stash = NULL;
2181 apply_attrs(GvSTASH(gv),
2182 (type == OP_RV2SV ? GvSV(gv) :
2183 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2184 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2187 o->op_private |= OPpOUR_INTRO;
2190 else if (type != OP_PADSV &&
2193 type != OP_PUSHMARK)
2195 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2197 PL_parser->in_my == KEY_our
2199 : PL_parser->in_my == KEY_state ? "state" : "my"));
2202 else if (attrs && type != OP_PUSHMARK) {
2205 PL_parser->in_my = FALSE;
2206 PL_parser->in_my_stash = NULL;
2208 /* check for C<my Dog $spot> when deciding package */
2209 stash = PAD_COMPNAME_TYPE(o->op_targ);
2211 stash = PL_curstash;
2212 apply_attrs_my(stash, o, attrs, imopsp);
2214 o->op_flags |= OPf_MOD;
2215 o->op_private |= OPpLVAL_INTRO;
2216 if (PL_parser->in_my == KEY_state)
2217 o->op_private |= OPpPAD_STATE;
2222 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2226 int maybe_scalar = 0;
2228 PERL_ARGS_ASSERT_MY_ATTRS;
2230 /* [perl #17376]: this appears to be premature, and results in code such as
2231 C< our(%x); > executing in list mode rather than void mode */
2233 if (o->op_flags & OPf_PARENS)
2243 o = my_kid(o, attrs, &rops);
2245 if (maybe_scalar && o->op_type == OP_PADSV) {
2246 o = scalar(op_append_list(OP_LIST, rops, o));
2247 o->op_private |= OPpLVAL_INTRO;
2250 o = op_append_list(OP_LIST, o, rops);
2252 PL_parser->in_my = FALSE;
2253 PL_parser->in_my_stash = NULL;
2258 Perl_sawparens(pTHX_ OP *o)
2260 PERL_UNUSED_CONTEXT;
2262 o->op_flags |= OPf_PARENS;
2267 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2271 const OPCODE ltype = left->op_type;
2272 const OPCODE rtype = right->op_type;
2274 PERL_ARGS_ASSERT_BIND_MATCH;
2276 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2277 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2279 const char * const desc
2281 rtype == OP_SUBST || rtype == OP_TRANS
2282 || rtype == OP_TRANSR
2284 ? (int)rtype : OP_MATCH];
2285 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2286 ? "@array" : "%hash");
2287 Perl_warner(aTHX_ packWARN(WARN_MISC),
2288 "Applying %s to %s will act on scalar(%s)",
2289 desc, sample, sample);
2292 if (rtype == OP_CONST &&
2293 cSVOPx(right)->op_private & OPpCONST_BARE &&
2294 cSVOPx(right)->op_private & OPpCONST_STRICT)
2296 no_bareword_allowed(right);
2299 /* !~ doesn't make sense with /r, so error on it for now */
2300 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2302 yyerror("Using !~ with s///r doesn't make sense");
2303 if (rtype == OP_TRANSR && type == OP_NOT)
2304 yyerror("Using !~ with tr///r doesn't make sense");
2306 ismatchop = (rtype == OP_MATCH ||
2307 rtype == OP_SUBST ||
2308 rtype == OP_TRANS || rtype == OP_TRANSR)
2309 && !(right->op_flags & OPf_SPECIAL);
2310 if (ismatchop && right->op_private & OPpTARGET_MY) {
2312 right->op_private &= ~OPpTARGET_MY;
2314 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2317 right->op_flags |= OPf_STACKED;
2318 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2319 ! (rtype == OP_TRANS &&
2320 right->op_private & OPpTRANS_IDENTICAL) &&
2321 ! (rtype == OP_SUBST &&
2322 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2323 newleft = op_lvalue(left, rtype);
2326 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2327 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2329 o = op_prepend_elem(rtype, scalar(newleft), right);
2331 return newUNOP(OP_NOT, 0, scalar(o));
2335 return bind_match(type, left,
2336 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2340 Perl_invert(pTHX_ OP *o)
2344 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2348 =for apidoc Amx|OP *|op_scope|OP *o
2350 Wraps up an op tree with some additional ops so that at runtime a dynamic
2351 scope will be created. The original ops run in the new dynamic scope,
2352 and then, provided that they exit normally, the scope will be unwound.
2353 The additional ops used to create and unwind the dynamic scope will
2354 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2355 instead if the ops are simple enough to not need the full dynamic scope
2362 Perl_op_scope(pTHX_ OP *o)
2366 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2367 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2368 o->op_type = OP_LEAVE;
2369 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2371 else if (o->op_type == OP_LINESEQ) {
2373 o->op_type = OP_SCOPE;
2374 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2375 kid = ((LISTOP*)o)->op_first;
2376 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2379 /* The following deals with things like 'do {1 for 1}' */
2380 kid = kid->op_sibling;
2382 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2387 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2393 Perl_block_start(pTHX_ int full)
2396 const int retval = PL_savestack_ix;
2398 pad_block_start(full);
2400 PL_hints &= ~HINT_BLOCK_SCOPE;
2401 SAVECOMPILEWARNINGS();
2402 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2404 CALL_BLOCK_HOOKS(bhk_start, full);
2410 Perl_block_end(pTHX_ I32 floor, OP *seq)
2413 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2414 OP* retval = scalarseq(seq);
2416 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2419 CopHINTS_set(&PL_compiling, PL_hints);
2421 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2424 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2430 =head1 Compile-time scope hooks
2432 =for apidoc Ao||blockhook_register
2434 Register a set of hooks to be called when the Perl lexical scope changes
2435 at compile time. See L<perlguts/"Compile-time scope hooks">.
2441 Perl_blockhook_register(pTHX_ BHK *hk)
2443 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2445 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2452 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2453 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2454 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2457 OP * const o = newOP(OP_PADSV, 0);
2458 o->op_targ = offset;
2464 Perl_newPROG(pTHX_ OP *o)
2468 PERL_ARGS_ASSERT_NEWPROG;
2473 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2474 ((PL_in_eval & EVAL_KEEPERR)
2475 ? OPf_SPECIAL : 0), o);
2476 /* don't use LINKLIST, since PL_eval_root might indirect through
2477 * a rather expensive function call and LINKLIST evaluates its
2478 * argument more than once */
2479 PL_eval_start = op_linklist(PL_eval_root);
2480 PL_eval_root->op_private |= OPpREFCOUNTED;
2481 OpREFCNT_set(PL_eval_root, 1);
2482 PL_eval_root->op_next = 0;
2483 CALL_PEEP(PL_eval_start);
2486 if (o->op_type == OP_STUB) {
2487 PL_comppad_name = 0;
2489 S_op_destroy(aTHX_ o);
2492 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2493 PL_curcop = &PL_compiling;
2494 PL_main_start = LINKLIST(PL_main_root);
2495 PL_main_root->op_private |= OPpREFCOUNTED;
2496 OpREFCNT_set(PL_main_root, 1);
2497 PL_main_root->op_next = 0;
2498 CALL_PEEP(PL_main_start);
2501 /* Register with debugger */
2503 CV * const cv = get_cvs("DB::postponed", 0);
2507 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2509 call_sv(MUTABLE_SV(cv), G_DISCARD);
2516 Perl_localize(pTHX_ OP *o, I32 lex)
2520 PERL_ARGS_ASSERT_LOCALIZE;
2522 if (o->op_flags & OPf_PARENS)
2523 /* [perl #17376]: this appears to be premature, and results in code such as
2524 C< our(%x); > executing in list mode rather than void mode */
2531 if ( PL_parser->bufptr > PL_parser->oldbufptr
2532 && PL_parser->bufptr[-1] == ','
2533 && ckWARN(WARN_PARENTHESIS))
2535 char *s = PL_parser->bufptr;
2538 /* some heuristics to detect a potential error */
2539 while (*s && (strchr(", \t\n", *s)))
2543 if (*s && strchr("@$%*", *s) && *++s
2544 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2547 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2549 while (*s && (strchr(", \t\n", *s)))
2555 if (sigil && (*s == ';' || *s == '=')) {
2556 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2557 "Parentheses missing around \"%s\" list",
2559 ? (PL_parser->in_my == KEY_our
2561 : PL_parser->in_my == KEY_state
2571 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2572 PL_parser->in_my = FALSE;
2573 PL_parser->in_my_stash = NULL;
2578 Perl_jmaybe(pTHX_ OP *o)
2580 PERL_ARGS_ASSERT_JMAYBE;
2582 if (o->op_type == OP_LIST) {
2584 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2585 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2591 S_fold_constants(pTHX_ register OP *o)
2594 register OP * VOL curop;
2596 VOL I32 type = o->op_type;
2601 SV * const oldwarnhook = PL_warnhook;
2602 SV * const olddiehook = PL_diehook;
2606 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2608 if (PL_opargs[type] & OA_RETSCALAR)
2610 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2611 o->op_targ = pad_alloc(type, SVs_PADTMP);
2613 /* integerize op, unless it happens to be C<-foo>.
2614 * XXX should pp_i_negate() do magic string negation instead? */
2615 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2616 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2617 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2619 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2622 if (!(PL_opargs[type] & OA_FOLDCONST))
2627 /* XXX might want a ck_negate() for this */
2628 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2640 /* XXX what about the numeric ops? */
2641 if (PL_hints & HINT_LOCALE)
2646 if (PL_parser && PL_parser->error_count)
2647 goto nope; /* Don't try to run w/ errors */
2649 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2650 const OPCODE type = curop->op_type;
2651 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2653 type != OP_SCALAR &&
2655 type != OP_PUSHMARK)
2661 curop = LINKLIST(o);
2662 old_next = o->op_next;
2666 oldscope = PL_scopestack_ix;
2667 create_eval_scope(G_FAKINGEVAL);
2669 /* Verify that we don't need to save it: */
2670 assert(PL_curcop == &PL_compiling);
2671 StructCopy(&PL_compiling, ¬_compiling, COP);
2672 PL_curcop = ¬_compiling;
2673 /* The above ensures that we run with all the correct hints of the
2674 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2675 assert(IN_PERL_RUNTIME);
2676 PL_warnhook = PERL_WARNHOOK_FATAL;
2683 sv = *(PL_stack_sp--);
2684 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2685 pad_swipe(o->op_targ, FALSE);
2686 else if (SvTEMP(sv)) { /* grab mortal temp? */
2687 SvREFCNT_inc_simple_void(sv);
2692 /* Something tried to die. Abandon constant folding. */
2693 /* Pretend the error never happened. */
2695 o->op_next = old_next;
2699 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2700 PL_warnhook = oldwarnhook;
2701 PL_diehook = olddiehook;
2702 /* XXX note that this croak may fail as we've already blown away
2703 * the stack - eg any nested evals */
2704 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2707 PL_warnhook = oldwarnhook;
2708 PL_diehook = olddiehook;
2709 PL_curcop = &PL_compiling;
2711 if (PL_scopestack_ix > oldscope)
2712 delete_eval_scope();
2721 if (type == OP_RV2GV)
2722 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2724 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2725 op_getmad(o,newop,'f');
2733 S_gen_constant_list(pTHX_ register OP *o)
2737 const I32 oldtmps_floor = PL_tmps_floor;
2740 if (PL_parser && PL_parser->error_count)
2741 return o; /* Don't attempt to run with errors */
2743 PL_op = curop = LINKLIST(o);
2749 assert (!(curop->op_flags & OPf_SPECIAL));
2750 assert(curop->op_type == OP_RANGE);
2752 PL_tmps_floor = oldtmps_floor;
2754 o->op_type = OP_RV2AV;
2755 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2756 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2757 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2758 o->op_opt = 0; /* needs to be revisited in rpeep() */
2759 curop = ((UNOP*)o)->op_first;
2760 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2762 op_getmad(curop,o,'O');
2771 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2774 if (!o || o->op_type != OP_LIST)
2775 o = newLISTOP(OP_LIST, 0, o, NULL);
2777 o->op_flags &= ~OPf_WANT;
2779 if (!(PL_opargs[type] & OA_MARK))
2780 op_null(cLISTOPo->op_first);
2782 o->op_type = (OPCODE)type;
2783 o->op_ppaddr = PL_ppaddr[type];
2784 o->op_flags |= flags;
2786 o = CHECKOP(type, o);
2787 if (o->op_type != (unsigned)type)
2790 return fold_constants(o);
2794 =head1 Optree Manipulation Functions
2797 /* List constructors */
2800 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2802 Append an item to the list of ops contained directly within a list-type
2803 op, returning the lengthened list. I<first> is the list-type op,
2804 and I<last> is the op to append to the list. I<optype> specifies the
2805 intended opcode for the list. If I<first> is not already a list of the
2806 right type, it will be upgraded into one. If either I<first> or I<last>
2807 is null, the other is returned unchanged.
2813 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2821 if (first->op_type != (unsigned)type
2822 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2824 return newLISTOP(type, 0, first, last);
2827 if (first->op_flags & OPf_KIDS)
2828 ((LISTOP*)first)->op_last->op_sibling = last;
2830 first->op_flags |= OPf_KIDS;
2831 ((LISTOP*)first)->op_first = last;
2833 ((LISTOP*)first)->op_last = last;
2838 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2840 Concatenate the lists of ops contained directly within two list-type ops,
2841 returning the combined list. I<first> and I<last> are the list-type ops
2842 to concatenate. I<optype> specifies the intended opcode for the list.
2843 If either I<first> or I<last> is not already a list of the right type,
2844 it will be upgraded into one. If either I<first> or I<last> is null,
2845 the other is returned unchanged.
2851 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2859 if (first->op_type != (unsigned)type)
2860 return op_prepend_elem(type, first, last);
2862 if (last->op_type != (unsigned)type)
2863 return op_append_elem(type, first, last);
2865 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2866 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2867 first->op_flags |= (last->op_flags & OPf_KIDS);
2870 if (((LISTOP*)last)->op_first && first->op_madprop) {
2871 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2873 while (mp->mad_next)
2875 mp->mad_next = first->op_madprop;
2878 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2881 first->op_madprop = last->op_madprop;
2882 last->op_madprop = 0;
2885 S_op_destroy(aTHX_ last);
2891 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2893 Prepend an item to the list of ops contained directly within a list-type
2894 op, returning the lengthened list. I<first> is the op to prepend to the
2895 list, and I<last> is the list-type op. I<optype> specifies the intended
2896 opcode for the list. If I<last> is not already a list of the right type,
2897 it will be upgraded into one. If either I<first> or I<last> is null,
2898 the other is returned unchanged.
2904 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2912 if (last->op_type == (unsigned)type) {
2913 if (type == OP_LIST) { /* already a PUSHMARK there */
2914 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2915 ((LISTOP*)last)->op_first->op_sibling = first;
2916 if (!(first->op_flags & OPf_PARENS))
2917 last->op_flags &= ~OPf_PARENS;
2920 if (!(last->op_flags & OPf_KIDS)) {
2921 ((LISTOP*)last)->op_last = first;
2922 last->op_flags |= OPf_KIDS;
2924 first->op_sibling = ((LISTOP*)last)->op_first;
2925 ((LISTOP*)last)->op_first = first;
2927 last->op_flags |= OPf_KIDS;
2931 return newLISTOP(type, 0, first, last);
2939 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2942 Newxz(tk, 1, TOKEN);
2943 tk->tk_type = (OPCODE)optype;
2944 tk->tk_type = 12345;
2946 tk->tk_mad = madprop;
2951 Perl_token_free(pTHX_ TOKEN* tk)
2953 PERL_ARGS_ASSERT_TOKEN_FREE;
2955 if (tk->tk_type != 12345)
2957 mad_free(tk->tk_mad);
2962 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2967 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2969 if (tk->tk_type != 12345) {
2970 Perl_warner(aTHX_ packWARN(WARN_MISC),
2971 "Invalid TOKEN object ignored");
2978 /* faked up qw list? */
2980 tm->mad_type == MAD_SV &&
2981 SvPVX((SV *)tm->mad_val)[0] == 'q')
2988 /* pretend constant fold didn't happen? */
2989 if (mp->mad_key == 'f' &&
2990 (o->op_type == OP_CONST ||
2991 o->op_type == OP_GV) )
2993 token_getmad(tk,(OP*)mp->mad_val,slot);
3007 if (mp->mad_key == 'X')
3008 mp->mad_key = slot; /* just change the first one */
3018 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3027 /* pretend constant fold didn't happen? */
3028 if (mp->mad_key == 'f' &&
3029 (o->op_type == OP_CONST ||
3030 o->op_type == OP_GV) )
3032 op_getmad(from,(OP*)mp->mad_val,slot);
3039 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3042 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3048 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3057 /* pretend constant fold didn't happen? */
3058 if (mp->mad_key == 'f' &&
3059 (o->op_type == OP_CONST ||
3060 o->op_type == OP_GV) )
3062 op_getmad(from,(OP*)mp->mad_val,slot);
3069 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3072 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3076 PerlIO_printf(PerlIO_stderr(),
3077 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3083 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3101 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3105 addmad(tm, &(o->op_madprop), slot);
3109 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3130 Perl_newMADsv(pTHX_ char key, SV* sv)
3132 PERL_ARGS_ASSERT_NEWMADSV;
3134 return newMADPROP(key, MAD_SV, sv, 0);
3138 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3141 Newxz(mp, 1, MADPROP);
3144 mp->mad_vlen = vlen;
3145 mp->mad_type = type;
3147 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3152 Perl_mad_free(pTHX_ MADPROP* mp)
3154 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3158 mad_free(mp->mad_next);
3159 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3160 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3161 switch (mp->mad_type) {
3165 Safefree((char*)mp->mad_val);
3168 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3169 op_free((OP*)mp->mad_val);
3172 sv_free(MUTABLE_SV(mp->mad_val));
3175 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3184 =head1 Optree construction
3186 =for apidoc Am|OP *|newNULLLIST
3188 Constructs, checks, and returns a new C<stub> op, which represents an
3189 empty list expression.
3195 Perl_newNULLLIST(pTHX)
3197 return newOP(OP_STUB, 0);
3201 S_force_list(pTHX_ OP *o)
3203 if (!o || o->op_type != OP_LIST)
3204 o = newLISTOP(OP_LIST, 0, o, NULL);
3210 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3212 Constructs, checks, and returns an op of any list type. I<type> is
3213 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3214 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3215 supply up to two ops to be direct children of the list op; they are
3216 consumed by this function and become part of the constructed op tree.
3222 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3227 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3229 NewOp(1101, listop, 1, LISTOP);
3231 listop->op_type = (OPCODE)type;
3232 listop->op_ppaddr = PL_ppaddr[type];
3235 listop->op_flags = (U8)flags;
3239 else if (!first && last)
3242 first->op_sibling = last;
3243 listop->op_first = first;
3244 listop->op_last = last;
3245 if (type == OP_LIST) {
3246 OP* const pushop = newOP(OP_PUSHMARK, 0);
3247 pushop->op_sibling = first;
3248 listop->op_first = pushop;
3249 listop->op_flags |= OPf_KIDS;
3251 listop->op_last = pushop;
3254 return CHECKOP(type, listop);
3258 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3260 Constructs, checks, and returns an op of any base type (any type that
3261 has no extra fields). I<type> is the opcode. I<flags> gives the
3262 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3269 Perl_newOP(pTHX_ I32 type, I32 flags)
3274 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3275 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3276 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3277 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3279 NewOp(1101, o, 1, OP);
3280 o->op_type = (OPCODE)type;
3281 o->op_ppaddr = PL_ppaddr[type];
3282 o->op_flags = (U8)flags;
3284 o->op_latefreed = 0;
3288 o->op_private = (U8)(0 | (flags >> 8));
3289 if (PL_opargs[type] & OA_RETSCALAR)
3291 if (PL_opargs[type] & OA_TARGET)
3292 o->op_targ = pad_alloc(type, SVs_PADTMP);
3293 return CHECKOP(type, o);
3297 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3299 Constructs, checks, and returns an op of any unary type. I<type> is
3300 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3301 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3302 bits, the eight bits of C<op_private>, except that the bit with value 1
3303 is automatically set. I<first> supplies an optional op to be the direct
3304 child of the unary op; it is consumed by this function and become part
3305 of the constructed op tree.
3311 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3316 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3317 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3318 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3319 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3320 || type == OP_SASSIGN
3321 || type == OP_ENTERTRY
3322 || type == OP_NULL );
3325 first = newOP(OP_STUB, 0);
3326 if (PL_opargs[type] & OA_MARK)
3327 first = force_list(first);
3329 NewOp(1101, unop, 1, UNOP);
3330 unop->op_type = (OPCODE)type;
3331 unop->op_ppaddr = PL_ppaddr[type];
3332 unop->op_first = first;
3333 unop->op_flags = (U8)(flags | OPf_KIDS);
3334 unop->op_private = (U8)(1 | (flags >> 8));
3335 unop = (UNOP*) CHECKOP(type, unop);
3339 return fold_constants((OP *) unop);
3343 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3345 Constructs, checks, and returns an op of any binary type. I<type>
3346 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3347 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3348 the eight bits of C<op_private>, except that the bit with value 1 or
3349 2 is automatically set as required. I<first> and I<last> supply up to
3350 two ops to be the direct children of the binary op; they are consumed
3351 by this function and become part of the constructed op tree.
3357 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3362 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3363 || type == OP_SASSIGN || type == OP_NULL );
3365 NewOp(1101, binop, 1, BINOP);
3368 first = newOP(OP_NULL, 0);
3370 binop->op_type = (OPCODE)type;
3371 binop->op_ppaddr = PL_ppaddr[type];
3372 binop->op_first = first;
3373 binop->op_flags = (U8)(flags | OPf_KIDS);
3376 binop->op_private = (U8)(1 | (flags >> 8));
3379 binop->op_private = (U8)(2 | (flags >> 8));
3380 first->op_sibling = last;
3383 binop = (BINOP*)CHECKOP(type, binop);
3384 if (binop->op_next || binop->op_type != (OPCODE)type)
3387 binop->op_last = binop->op_first->op_sibling;
3389 return fold_constants((OP *)binop);
3392 static int uvcompare(const void *a, const void *b)
3393 __attribute__nonnull__(1)
3394 __attribute__nonnull__(2)
3395 __attribute__pure__;
3396 static int uvcompare(const void *a, const void *b)
3398 if (*((const UV *)a) < (*(const UV *)b))
3400 if (*((const UV *)a) > (*(const UV *)b))
3402 if (*((const UV *)a+1) < (*(const UV *)b+1))
3404 if (*((const UV *)a+1) > (*(const UV *)b+1))
3410 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3413 SV * const tstr = ((SVOP*)expr)->op_sv;
3416 (repl->op_type == OP_NULL)
3417 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3419 ((SVOP*)repl)->op_sv;
3422 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3423 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3427 register short *tbl;
3429 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3430 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3431 I32 del = o->op_private & OPpTRANS_DELETE;
3434 PERL_ARGS_ASSERT_PMTRANS;
3436 PL_hints |= HINT_BLOCK_SCOPE;
3439 o->op_private |= OPpTRANS_FROM_UTF;
3442 o->op_private |= OPpTRANS_TO_UTF;
3444 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3445 SV* const listsv = newSVpvs("# comment\n");
3447 const U8* tend = t + tlen;
3448 const U8* rend = r + rlen;
3462 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3463 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3466 const U32 flags = UTF8_ALLOW_DEFAULT;
3470 t = tsave = bytes_to_utf8(t, &len);
3473 if (!to_utf && rlen) {
3475 r = rsave = bytes_to_utf8(r, &len);
3479 /* There are several snags with this code on EBCDIC:
3480 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3481 2. scan_const() in toke.c has encoded chars in native encoding which makes
3482 ranges at least in EBCDIC 0..255 range the bottom odd.
3486 U8 tmpbuf[UTF8_MAXBYTES+1];
3489 Newx(cp, 2*tlen, UV);
3491 transv = newSVpvs("");
3493 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3495 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3497 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3501 cp[2*i+1] = cp[2*i];
3505 qsort(cp, i, 2*sizeof(UV), uvcompare);
3506 for (j = 0; j < i; j++) {
3508 diff = val - nextmin;
3510 t = uvuni_to_utf8(tmpbuf,nextmin);
3511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3513 U8 range_mark = UTF_TO_NATIVE(0xff);
3514 t = uvuni_to_utf8(tmpbuf, val - 1);
3515 sv_catpvn(transv, (char *)&range_mark, 1);
3516 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3523 t = uvuni_to_utf8(tmpbuf,nextmin);
3524 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3526 U8 range_mark = UTF_TO_NATIVE(0xff);
3527 sv_catpvn(transv, (char *)&range_mark, 1);
3529 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3530 UNICODE_ALLOW_SUPER);
3531 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3532 t = (const U8*)SvPVX_const(transv);
3533 tlen = SvCUR(transv);
3537 else if (!rlen && !del) {
3538 r = t; rlen = tlen; rend = tend;
3541 if ((!rlen && !del) || t == r ||
3542 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3544 o->op_private |= OPpTRANS_IDENTICAL;
3548 while (t < tend || tfirst <= tlast) {
3549 /* see if we need more "t" chars */
3550 if (tfirst > tlast) {
3551 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3553 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3555 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3562 /* now see if we need more "r" chars */
3563 if (rfirst > rlast) {
3565 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3567 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3569 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3578 rfirst = rlast = 0xffffffff;
3582 /* now see which range will peter our first, if either. */
3583 tdiff = tlast - tfirst;
3584 rdiff = rlast - rfirst;
3591 if (rfirst == 0xffffffff) {
3592 diff = tdiff; /* oops, pretend rdiff is infinite */
3594 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3595 (long)tfirst, (long)tlast);
3597 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3601 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3602 (long)tfirst, (long)(tfirst + diff),
3605 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3606 (long)tfirst, (long)rfirst);
3608 if (rfirst + diff > max)
3609 max = rfirst + diff;
3611 grows = (tfirst < rfirst &&
3612 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3624 else if (max > 0xff)
3629 PerlMemShared_free(cPVOPo->op_pv);
3630 cPVOPo->op_pv = NULL;
3632 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3634 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3635 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3636 PAD_SETSV(cPADOPo->op_padix, swash);
3638 SvREADONLY_on(swash);
3640 cSVOPo->op_sv = swash;
3642 SvREFCNT_dec(listsv);
3643 SvREFCNT_dec(transv);
3645 if (!del && havefinal && rlen)
3646 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3647 newSVuv((UV)final), 0);
3650 o->op_private |= OPpTRANS_GROWS;
3656 op_getmad(expr,o,'e');
3657 op_getmad(repl,o,'r');
3665 tbl = (short*)cPVOPo->op_pv;
3667 Zero(tbl, 256, short);
3668 for (i = 0; i < (I32)tlen; i++)
3670 for (i = 0, j = 0; i < 256; i++) {
3672 if (j >= (I32)rlen) {
3681 if (i < 128 && r[j] >= 128)
3691 o->op_private |= OPpTRANS_IDENTICAL;
3693 else if (j >= (I32)rlen)
3698 PerlMemShared_realloc(tbl,
3699 (0x101+rlen-j) * sizeof(short));
3700 cPVOPo->op_pv = (char*)tbl;
3702 tbl[0x100] = (short)(rlen - j);
3703 for (i=0; i < (I32)rlen - j; i++)
3704 tbl[0x101+i] = r[j+i];
3708 if (!rlen && !del) {
3711 o->op_private |= OPpTRANS_IDENTICAL;
3713 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3714 o->op_private |= OPpTRANS_IDENTICAL;
3716 for (i = 0; i < 256; i++)
3718 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3719 if (j >= (I32)rlen) {
3721 if (tbl[t[i]] == -1)
3727 if (tbl[t[i]] == -1) {
3728 if (t[i] < 128 && r[j] >= 128)
3735 if(del && rlen == tlen) {
3736 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3737 } else if(rlen > tlen) {
3738 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3742 o->op_private |= OPpTRANS_GROWS;
3744 op_getmad(expr,o,'e');
3745 op_getmad(repl,o,'r');
3755 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3757 Constructs, checks, and returns an op of any pattern matching type.
3758 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3759 and, shifted up eight bits, the eight bits of C<op_private>.
3765 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3770 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3772 NewOp(1101, pmop, 1, PMOP);
3773 pmop->op_type = (OPCODE)type;
3774 pmop->op_ppaddr = PL_ppaddr[type];
3775 pmop->op_flags = (U8)flags;
3776 pmop->op_private = (U8)(0 | (flags >> 8));
3778 if (PL_hints & HINT_RE_TAINT)
3779 pmop->op_pmflags |= PMf_RETAINT;
3780 if (PL_hints & HINT_LOCALE) {
3781 pmop->op_pmflags |= PMf_LOCALE;
3783 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3784 pmop->op_pmflags |= RXf_PMf_UNICODE;
3786 if (PL_hints & HINT_RE_FLAGS) {
3787 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3788 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3790 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3791 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3792 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3794 if (reflags && SvOK(reflags)) {
3795 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3796 pmop->op_pmflags |= SvIV(reflags);
3802 assert(SvPOK(PL_regex_pad[0]));
3803 if (SvCUR(PL_regex_pad[0])) {
3804 /* Pop off the "packed" IV from the end. */
3805 SV *const repointer_list = PL_regex_pad[0];
3806 const char *p = SvEND(repointer_list) - sizeof(IV);
3807 const IV offset = *((IV*)p);
3809 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3811 SvEND_set(repointer_list, p);
3813 pmop->op_pmoffset = offset;
3814 /* This slot should be free, so assert this: */
3815 assert(PL_regex_pad[offset] == &PL_sv_undef);
3817 SV * const repointer = &PL_sv_undef;
3818 av_push(PL_regex_padav, repointer);
3819 pmop->op_pmoffset = av_len(PL_regex_padav);
3820 PL_regex_pad = AvARRAY(PL_regex_padav);
3824 return CHECKOP(type, pmop);
3827 /* Given some sort of match op o, and an expression expr containing a
3828 * pattern, either compile expr into a regex and attach it to o (if it's
3829 * constant), or convert expr into a runtime regcomp op sequence (if it's
3832 * isreg indicates that the pattern is part of a regex construct, eg
3833 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3834 * split "pattern", which aren't. In the former case, expr will be a list
3835 * if the pattern contains more than one term (eg /a$b/) or if it contains
3836 * a replacement, ie s/// or tr///.
3840 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3845 I32 repl_has_vars = 0;
3849 PERL_ARGS_ASSERT_PMRUNTIME;
3852 o->op_type == OP_SUBST
3853 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3855 /* last element in list is the replacement; pop it */
3857 repl = cLISTOPx(expr)->op_last;
3858 kid = cLISTOPx(expr)->op_first;
3859 while (kid->op_sibling != repl)
3860 kid = kid->op_sibling;
3861 kid->op_sibling = NULL;
3862 cLISTOPx(expr)->op_last = kid;
3865 if (isreg && expr->op_type == OP_LIST &&
3866 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3868 /* convert single element list to element */
3869 OP* const oe = expr;
3870 expr = cLISTOPx(oe)->op_first->op_sibling;
3871 cLISTOPx(oe)->op_first->op_sibling = NULL;
3872 cLISTOPx(oe)->op_last = NULL;
3876 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3877 return pmtrans(o, expr, repl);
3880 reglist = isreg && expr->op_type == OP_LIST;
3884 PL_hints |= HINT_BLOCK_SCOPE;
3887 if (expr->op_type == OP_CONST) {
3888 SV *pat = ((SVOP*)expr)->op_sv;
3889 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3891 if (o->op_flags & OPf_SPECIAL)
3892 pm_flags |= RXf_SPLIT;
3895 assert (SvUTF8(pat));
3896 } else if (SvUTF8(pat)) {
3897 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3898 trapped in use 'bytes'? */
3899 /* Make a copy of the octet sequence, but without the flag on, as
3900 the compiler now honours the SvUTF8 flag on pat. */
3902 const char *const p = SvPV(pat, len);
3903 pat = newSVpvn_flags(p, len, SVs_TEMP);
3906 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3909 op_getmad(expr,(OP*)pm,'e');
3915 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3916 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3918 : OP_REGCMAYBE),0,expr);
3920 NewOp(1101, rcop, 1, LOGOP);
3921 rcop->op_type = OP_REGCOMP;
3922 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3923 rcop->op_first = scalar(expr);
3924 rcop->op_flags |= OPf_KIDS
3925 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3926 | (reglist ? OPf_STACKED : 0);
3927 rcop->op_private = 1;
3930 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3932 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3935 /* establish postfix order */
3936 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3938 rcop->op_next = expr;
3939 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3942 rcop->op_next = LINKLIST(expr);
3943 expr->op_next = (OP*)rcop;
3946 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3951 if (pm->op_pmflags & PMf_EVAL) {
3953 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3954 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3956 else if (repl->op_type == OP_CONST)
3960 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3961 if (curop->op_type == OP_SCOPE
3962 || curop->op_type == OP_LEAVE
3963 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3964 if (curop->op_type == OP_GV) {
3965 GV * const gv = cGVOPx_gv(curop);
3967 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3970 else if (curop->op_type == OP_RV2CV)
3972 else if (curop->op_type == OP_RV2SV ||
3973 curop->op_type == OP_RV2AV ||
3974 curop->op_type == OP_RV2HV ||
3975 curop->op_type == OP_RV2GV) {
3976 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3979 else if (curop->op_type == OP_PADSV ||
3980 curop->op_type == OP_PADAV ||
3981 curop->op_type == OP_PADHV ||
3982 curop->op_type == OP_PADANY)
3986 else if (curop->op_type == OP_PUSHRE)
3987 NOOP; /* Okay here, dangerous in newASSIGNOP */
3997 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3999 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4000 op_prepend_elem(o->op_type, scalar(repl), o);
4003 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4004 pm->op_pmflags |= PMf_MAYBE_CONST;
4006 NewOp(1101, rcop, 1, LOGOP);
4007 rcop->op_type = OP_SUBSTCONT;
4008 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4009 rcop->op_first = scalar(repl);
4010 rcop->op_flags |= OPf_KIDS;
4011 rcop->op_private = 1;
4014 /* establish postfix order */
4015 rcop->op_next = LINKLIST(repl);
4016 repl->op_next = (OP*)rcop;
4018 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4019 assert(!(pm->op_pmflags & PMf_ONCE));
4020 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4029 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4031 Constructs, checks, and returns an op of any type that involves an
4032 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4033 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4034 takes ownership of one reference to it.
4040 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4045 PERL_ARGS_ASSERT_NEWSVOP;
4047 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4048 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4049 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4051 NewOp(1101, svop, 1, SVOP);
4052 svop->op_type = (OPCODE)type;
4053 svop->op_ppaddr = PL_ppaddr[type];
4055 svop->op_next = (OP*)svop;
4056 svop->op_flags = (U8)flags;
4057 if (PL_opargs[type] & OA_RETSCALAR)
4059 if (PL_opargs[type] & OA_TARGET)
4060 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4061 return CHECKOP(type, svop);
4067 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4069 Constructs, checks, and returns an op of any type that involves a
4070 reference to a pad element. I<type> is the opcode. I<flags> gives the
4071 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4072 is populated with I<sv>; this function takes ownership of one reference
4075 This function only exists if Perl has been compiled to use ithreads.
4081 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4086 PERL_ARGS_ASSERT_NEWPADOP;
4088 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4089 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4090 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4092 NewOp(1101, padop, 1, PADOP);
4093 padop->op_type = (OPCODE)type;
4094 padop->op_ppaddr = PL_ppaddr[type];
4095 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4096 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4097 PAD_SETSV(padop->op_padix, sv);
4100 padop->op_next = (OP*)padop;
4101 padop->op_flags = (U8)flags;
4102 if (PL_opargs[type] & OA_RETSCALAR)
4104 if (PL_opargs[type] & OA_TARGET)
4105 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4106 return CHECKOP(type, padop);
4109 #endif /* !USE_ITHREADS */
4112 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4114 Constructs, checks, and returns an op of any type that involves an
4115 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4116 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4117 reference; calling this function does not transfer ownership of any
4124 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4128 PERL_ARGS_ASSERT_NEWGVOP;
4132 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4134 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4139 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4141 Constructs, checks, and returns an op of any type that involves an
4142 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4143 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4144 must have been allocated using L</PerlMemShared_malloc>; the memory will
4145 be freed when the op is destroyed.
4151 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4156 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4157 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4159 NewOp(1101, pvop, 1, PVOP);
4160 pvop->op_type = (OPCODE)type;
4161 pvop->op_ppaddr = PL_ppaddr[type];
4163 pvop->op_next = (OP*)pvop;
4164 pvop->op_flags = (U8)flags;
4165 if (PL_opargs[type] & OA_RETSCALAR)
4167 if (PL_opargs[type] & OA_TARGET)
4168 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4169 return CHECKOP(type, pvop);
4177 Perl_package(pTHX_ OP *o)
4180 SV *const sv = cSVOPo->op_sv;
4185 PERL_ARGS_ASSERT_PACKAGE;
4187 save_hptr(&PL_curstash);
4188 save_item(PL_curstname);
4190 PL_curstash = gv_stashsv(sv, GV_ADD);
4192 sv_setsv(PL_curstname, sv);
4194 PL_hints |= HINT_BLOCK_SCOPE;
4195 PL_parser->copline = NOLINE;
4196 PL_parser->expect = XSTATE;
4201 if (!PL_madskills) {
4206 pegop = newOP(OP_NULL,0);
4207 op_getmad(o,pegop,'P');
4213 Perl_package_version( pTHX_ OP *v )
4216 U32 savehints = PL_hints;
4217 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4218 PL_hints &= ~HINT_STRICT_VARS;
4219 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4220 PL_hints = savehints;
4229 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4236 OP *pegop = newOP(OP_NULL,0);
4238 SV *use_version = NULL;
4240 PERL_ARGS_ASSERT_UTILIZE;
4242 if (idop->op_type != OP_CONST)
4243 Perl_croak(aTHX_ "Module name must be constant");
4246 op_getmad(idop,pegop,'U');
4251 SV * const vesv = ((SVOP*)version)->op_sv;
4254 op_getmad(version,pegop,'V');
4255 if (!arg && !SvNIOKp(vesv)) {
4262 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4263 Perl_croak(aTHX_ "Version number must be a constant number");
4265 /* Make copy of idop so we don't free it twice */
4266 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4268 /* Fake up a method call to VERSION */
4269 meth = newSVpvs_share("VERSION");
4270 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4271 op_append_elem(OP_LIST,
4272 op_prepend_elem(OP_LIST, pack, list(version)),
4273 newSVOP(OP_METHOD_NAMED, 0, meth)));
4277 /* Fake up an import/unimport */
4278 if (arg && arg->op_type == OP_STUB) {
4280 op_getmad(arg,pegop,'S');
4281 imop = arg; /* no import on explicit () */
4283 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4284 imop = NULL; /* use 5.0; */
4286 use_version = ((SVOP*)idop)->op_sv;
4288 idop->op_private |= OPpCONST_NOVER;
4294 op_getmad(arg,pegop,'A');
4296 /* Make copy of idop so we don't free it twice */
4297 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4299 /* Fake up a method call to import/unimport */
4301 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4302 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4303 op_append_elem(OP_LIST,
4304 op_prepend_elem(OP_LIST, pack, list(arg)),
4305 newSVOP(OP_METHOD_NAMED, 0, meth)));
4308 /* Fake up the BEGIN {}, which does its thing immediately. */
4310 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4313 op_append_elem(OP_LINESEQ,
4314 op_append_elem(OP_LINESEQ,
4315 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4316 newSTATEOP(0, NULL, veop)),
4317 newSTATEOP(0, NULL, imop) ));
4320 /* If we request a version >= 5.9.5, load feature.pm with the
4321 * feature bundle that corresponds to the required version. */
4322 use_version = sv_2mortal(new_version(use_version));
4324 if (vcmp(use_version,
4325 sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
4326 SV *const importsv = vnormal(use_version);
4327 *SvPVX_mutable(importsv) = ':';
4328 ENTER_with_name("load_feature");
4329 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
4330 LEAVE_with_name("load_feature");
4332 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4333 if (vcmp(use_version,
4334 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4335 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
4339 /* The "did you use incorrect case?" warning used to be here.
4340 * The problem is that on case-insensitive filesystems one
4341 * might get false positives for "use" (and "require"):
4342 * "use Strict" or "require CARP" will work. This causes
4343 * portability problems for the script: in case-strict
4344 * filesystems the script will stop working.
4346 * The "incorrect case" warning checked whether "use Foo"
4347 * imported "Foo" to your namespace, but that is wrong, too:
4348 * there is no requirement nor promise in the language that
4349 * a Foo.pm should or would contain anything in package "Foo".
4351 * There is very little Configure-wise that can be done, either:
4352 * the case-sensitivity of the build filesystem of Perl does not
4353 * help in guessing the case-sensitivity of the runtime environment.
4356 PL_hints |= HINT_BLOCK_SCOPE;
4357 PL_parser->copline = NOLINE;
4358 PL_parser->expect = XSTATE;
4359 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4362 if (!PL_madskills) {
4363 /* FIXME - don't allocate pegop if !PL_madskills */
4372 =head1 Embedding Functions
4374 =for apidoc load_module
4376 Loads the module whose name is pointed to by the string part of name.
4377 Note that the actual module name, not its filename, should be given.
4378 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4379 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4380 (or 0 for no flags). ver, if specified, provides version semantics
4381 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4382 arguments can be used to specify arguments to the module's import()
4383 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4384 terminated with a final NULL pointer. Note that this list can only
4385 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4386 Otherwise at least a single NULL pointer to designate the default
4387 import list is required.
4392 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4396 PERL_ARGS_ASSERT_LOAD_MODULE;
4398 va_start(args, ver);
4399 vload_module(flags, name, ver, &args);
4403 #ifdef PERL_IMPLICIT_CONTEXT
4405 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4409 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4410 va_start(args, ver);
4411 vload_module(flags, name, ver, &args);
4417 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4421 OP * const modname = newSVOP(OP_CONST, 0, name);
4423 PERL_ARGS_ASSERT_VLOAD_MODULE;
4425 modname->op_private |= OPpCONST_BARE;
4427 veop = newSVOP(OP_CONST, 0, ver);
4431 if (flags & PERL_LOADMOD_NOIMPORT) {
4432 imop = sawparens(newNULLLIST());
4434 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4435 imop = va_arg(*args, OP*);
4440 sv = va_arg(*args, SV*);
4442 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4443 sv = va_arg(*args, SV*);
4447 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4448 * that it has a PL_parser to play with while doing that, and also
4449 * that it doesn't mess with any existing parser, by creating a tmp
4450 * new parser with lex_start(). This won't actually be used for much,
4451 * since pp_require() will create another parser for the real work. */
4454 SAVEVPTR(PL_curcop);
4455 lex_start(NULL, NULL, 0);
4456 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4457 veop, modname, imop);
4462 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4468 PERL_ARGS_ASSERT_DOFILE;
4470 if (!force_builtin) {
4471 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4472 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4473 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4474 gv = gvp ? *gvp : NULL;
4478 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4479 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4480 op_append_elem(OP_LIST, term,
4481 scalar(newUNOP(OP_RV2CV, 0,
4482 newGVOP(OP_GV, 0, gv))))));
4485 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4491 =head1 Optree construction
4493 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4495 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4496 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4497 be set automatically, and, shifted up eight bits, the eight bits of
4498 C<op_private>, except that the bit with value 1 or 2 is automatically
4499 set as required. I<listval> and I<subscript> supply the parameters of
4500 the slice; they are consumed by this function and become part of the
4501 constructed op tree.
4507 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4509 return newBINOP(OP_LSLICE, flags,
4510 list(force_list(subscript)),
4511 list(force_list(listval)) );
4515 S_is_list_assignment(pTHX_ register const OP *o)
4523 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4524 o = cUNOPo->op_first;
4526 flags = o->op_flags;
4528 if (type == OP_COND_EXPR) {
4529 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4530 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4535 yyerror("Assignment to both a list and a scalar");
4539 if (type == OP_LIST &&
4540 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4541 o->op_private & OPpLVAL_INTRO)
4544 if (type == OP_LIST || flags & OPf_PARENS ||
4545 type == OP_RV2AV || type == OP_RV2HV ||
4546 type == OP_ASLICE || type == OP_HSLICE)
4549 if (type == OP_PADAV || type == OP_PADHV)
4552 if (type == OP_RV2SV)
4559 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4561 Constructs, checks, and returns an assignment op. I<left> and I<right>
4562 supply the parameters of the assignment; they are consumed by this
4563 function and become part of the constructed op tree.
4565 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4566 a suitable conditional optree is constructed. If I<optype> is the opcode
4567 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4568 performs the binary operation and assigns the result to the left argument.
4569 Either way, if I<optype> is non-zero then I<flags> has no effect.
4571 If I<optype> is zero, then a plain scalar or list assignment is
4572 constructed. Which type of assignment it is is automatically determined.
4573 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4574 will be set automatically, and, shifted up eight bits, the eight bits
4575 of C<op_private>, except that the bit with value 1 or 2 is automatically
4582 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4588 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4589 return newLOGOP(optype, 0,
4590 op_lvalue(scalar(left), optype),
4591 newUNOP(OP_SASSIGN, 0, scalar(right)));
4594 return newBINOP(optype, OPf_STACKED,
4595 op_lvalue(scalar(left), optype), scalar(right));
4599 if (is_list_assignment(left)) {
4600 static const char no_list_state[] = "Initialization of state variables"
4601 " in list context currently forbidden";
4603 bool maybe_common_vars = TRUE;
4606 /* Grandfathering $[ assignment here. Bletch.*/
4607 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4608 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4609 left = op_lvalue(left, OP_AASSIGN);
4612 else if (left->op_type == OP_CONST) {
4613 deprecate("assignment to $[");
4615 /* Result of assignment is always 1 (or we'd be dead already) */
4616 return newSVOP(OP_CONST, 0, newSViv(1));
4618 curop = list(force_list(left));
4619 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4620 o->op_private = (U8)(0 | (flags >> 8));
4622 if ((left->op_type == OP_LIST
4623 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4625 OP* lop = ((LISTOP*)left)->op_first;
4626 maybe_common_vars = FALSE;
4628 if (lop->op_type == OP_PADSV ||
4629 lop->op_type == OP_PADAV ||
4630 lop->op_type == OP_PADHV ||
4631 lop->op_type == OP_PADANY) {
4632 if (!(lop->op_private & OPpLVAL_INTRO))
4633 maybe_common_vars = TRUE;
4635 if (lop->op_private & OPpPAD_STATE) {
4636 if (left->op_private & OPpLVAL_INTRO) {
4637 /* Each variable in state($a, $b, $c) = ... */
4640 /* Each state variable in
4641 (state $a, my $b, our $c, $d, undef) = ... */
4643 yyerror(no_list_state);
4645 /* Each my variable in
4646 (state $a, my $b, our $c, $d, undef) = ... */
4648 } else if (lop->op_type == OP_UNDEF ||
4649 lop->op_type == OP_PUSHMARK) {
4650 /* undef may be interesting in
4651 (state $a, undef, state $c) */
4653 /* Other ops in the list. */
4654 maybe_common_vars = TRUE;
4656 lop = lop->op_sibling;
4659 else if ((left->op_private & OPpLVAL_INTRO)
4660 && ( left->op_type == OP_PADSV
4661 || left->op_type == OP_PADAV
4662 || left->op_type == OP_PADHV
4663 || left->op_type == OP_PADANY))
4665 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4666 if (left->op_private & OPpPAD_STATE) {
4667 /* All single variable list context state assignments, hence
4677 yyerror(no_list_state);
4681 /* PL_generation sorcery:
4682 * an assignment like ($a,$b) = ($c,$d) is easier than
4683 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4684 * To detect whether there are common vars, the global var
4685 * PL_generation is incremented for each assign op we compile.
4686 * Then, while compiling the assign op, we run through all the
4687 * variables on both sides of the assignment, setting a spare slot
4688 * in each of them to PL_generation. If any of them already have
4689 * that value, we know we've got commonality. We could use a
4690 * single bit marker, but then we'd have to make 2 passes, first
4691 * to clear the flag, then to test and set it. To find somewhere
4692 * to store these values, evil chicanery is done with SvUVX().
4695 if (maybe_common_vars) {
4698 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4699 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4700 if (curop->op_type == OP_GV) {
4701 GV *gv = cGVOPx_gv(curop);
4703 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4705 GvASSIGN_GENERATION_set(gv, PL_generation);
4707 else if (curop->op_type == OP_PADSV ||
4708 curop->op_type == OP_PADAV ||
4709 curop->op_type == OP_PADHV ||
4710 curop->op_type == OP_PADANY)
4712 if (PAD_COMPNAME_GEN(curop->op_targ)
4713 == (STRLEN)PL_generation)
4715 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4718 else if (curop->op_type == OP_RV2CV)
4720 else if (curop->op_type == OP_RV2SV ||
4721 curop->op_type == OP_RV2AV ||
4722 curop->op_type == OP_RV2HV ||
4723 curop->op_type == OP_RV2GV) {
4724 if (lastop->op_type != OP_GV) /* funny deref? */
4727 else if (curop->op_type == OP_PUSHRE) {
4729 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4730 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4732 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4734 GvASSIGN_GENERATION_set(gv, PL_generation);
4738 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4741 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4743 GvASSIGN_GENERATION_set(gv, PL_generation);
4753 o->op_private |= OPpASSIGN_COMMON;
4756 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4757 OP* tmpop = ((LISTOP*)right)->op_first;
4758 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4759 PMOP * const pm = (PMOP*)tmpop;
4760 if (left->op_type == OP_RV2AV &&
4761 !(left->op_private & OPpLVAL_INTRO) &&
4762 !(o->op_private & OPpASSIGN_COMMON) )
4764 tmpop = ((UNOP*)left)->op_first;
4765 if (tmpop->op_type == OP_GV
4767 && !pm->op_pmreplrootu.op_pmtargetoff
4769 && !pm->op_pmreplrootu.op_pmtargetgv
4773 pm->op_pmreplrootu.op_pmtargetoff
4774 = cPADOPx(tmpop)->op_padix;
4775 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4777 pm->op_pmreplrootu.op_pmtargetgv
4778 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4779 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4781 pm->op_pmflags |= PMf_ONCE;
4782 tmpop = cUNOPo->op_first; /* to list (nulled) */
4783 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4784 tmpop->op_sibling = NULL; /* don't free split */
4785 right->op_next = tmpop->op_next; /* fix starting loc */
4786 op_free(o); /* blow off assign */
4787 right->op_flags &= ~OPf_WANT;
4788 /* "I don't know and I don't care." */
4793 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4794 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4796 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4797 if (SvIOK(sv) && SvIVX(sv) == 0)
4798 sv_setiv(sv, PL_modcount+1);
4806 right = newOP(OP_UNDEF, 0);
4807 if (right->op_type == OP_READLINE) {
4808 right->op_flags |= OPf_STACKED;
4809 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4813 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4814 o = newBINOP(OP_SASSIGN, flags,
4815 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4819 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4820 deprecate("assignment to $[");
4822 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4823 o->op_private |= OPpCONST_ARYBASE;
4831 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4833 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4834 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4835 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4836 If I<label> is non-null, it supplies the name of a label to attach to
4837 the state op; this function takes ownership of the memory pointed at by
4838 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4841 If I<o> is null, the state op is returned. Otherwise the state op is
4842 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4843 is consumed by this function and becomes part of the returned op tree.
4849 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4852 const U32 seq = intro_my();
4855 NewOp(1101, cop, 1, COP);
4856 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4857 cop->op_type = OP_DBSTATE;
4858 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4861 cop->op_type = OP_NEXTSTATE;
4862 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4864 cop->op_flags = (U8)flags;
4865 CopHINTS_set(cop, PL_hints);
4867 cop->op_private |= NATIVE_HINTS;
4869 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4870 cop->op_next = (OP*)cop;
4873 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4874 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4876 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4877 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4879 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4881 PL_hints |= HINT_BLOCK_SCOPE;
4882 /* It seems that we need to defer freeing this pointer, as other parts
4883 of the grammar end up wanting to copy it after this op has been
4888 if (PL_parser && PL_parser->copline == NOLINE)
4889 CopLINE_set(cop, CopLINE(PL_curcop));
4891 CopLINE_set(cop, PL_parser->copline);
4893 PL_parser->copline = NOLINE;
4896 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4898 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4900 CopSTASH_set(cop, PL_curstash);
4902 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4903 /* this line can have a breakpoint - store the cop in IV */
4904 AV *av = CopFILEAVx(PL_curcop);
4906 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4907 if (svp && *svp != &PL_sv_undef ) {
4908 (void)SvIOK_on(*svp);
4909 SvIV_set(*svp, PTR2IV(cop));
4914 if (flags & OPf_SPECIAL)
4916 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4920 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4922 Constructs, checks, and returns a logical (flow control) op. I<type>
4923 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4924 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4925 the eight bits of C<op_private>, except that the bit with value 1 is
4926 automatically set. I<first> supplies the expression controlling the
4927 flow, and I<other> supplies the side (alternate) chain of ops; they are
4928 consumed by this function and become part of the constructed op tree.
4934 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4938 PERL_ARGS_ASSERT_NEWLOGOP;
4940 return new_logop(type, flags, &first, &other);
4944 S_search_const(pTHX_ OP *o)
4946 PERL_ARGS_ASSERT_SEARCH_CONST;
4948 switch (o->op_type) {
4952 if (o->op_flags & OPf_KIDS)
4953 return search_const(cUNOPo->op_first);
4960 if (!(o->op_flags & OPf_KIDS))
4962 kid = cLISTOPo->op_first;
4964 switch (kid->op_type) {
4968 kid = kid->op_sibling;
4971 if (kid != cLISTOPo->op_last)
4977 kid = cLISTOPo->op_last;
4979 return search_const(kid);
4987 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4995 int prepend_not = 0;
4997 PERL_ARGS_ASSERT_NEW_LOGOP;
5002 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5003 return newBINOP(type, flags, scalar(first), scalar(other));
5005 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5007 scalarboolean(first);
5008 /* optimize AND and OR ops that have NOTs as children */
5009 if (first->op_type == OP_NOT
5010 && (first->op_flags & OPf_KIDS)
5011 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5012 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5014 if (type == OP_AND || type == OP_OR) {
5020 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5022 prepend_not = 1; /* prepend a NOT op later */
5026 /* search for a constant op that could let us fold the test */
5027 if ((cstop = search_const(first))) {
5028 if (cstop->op_private & OPpCONST_STRICT)
5029 no_bareword_allowed(cstop);
5030 else if ((cstop->op_private & OPpCONST_BARE))
5031 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5032 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5033 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5034 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5036 if (other->op_type == OP_CONST)
5037 other->op_private |= OPpCONST_SHORTCIRCUIT;
5039 OP *newop = newUNOP(OP_NULL, 0, other);
5040 op_getmad(first, newop, '1');
5041 newop->op_targ = type; /* set "was" field */
5045 if (other->op_type == OP_LEAVE)
5046 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5047 else if (other->op_type == OP_MATCH
5048 || other->op_type == OP_SUBST
5049 || other->op_type == OP_TRANSR
5050 || other->op_type == OP_TRANS)
5051 /* Mark the op as being unbindable with =~ */
5052 other->op_flags |= OPf_SPECIAL;
5056 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5057 const OP *o2 = other;
5058 if ( ! (o2->op_type == OP_LIST
5059 && (( o2 = cUNOPx(o2)->op_first))
5060 && o2->op_type == OP_PUSHMARK
5061 && (( o2 = o2->op_sibling)) )
5064 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5065 || o2->op_type == OP_PADHV)
5066 && o2->op_private & OPpLVAL_INTRO
5067 && !(o2->op_private & OPpPAD_STATE))
5069 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5070 "Deprecated use of my() in false conditional");
5074 if (first->op_type == OP_CONST)
5075 first->op_private |= OPpCONST_SHORTCIRCUIT;
5077 first = newUNOP(OP_NULL, 0, first);
5078 op_getmad(other, first, '2');
5079 first->op_targ = type; /* set "was" field */
5086 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5087 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5089 const OP * const k1 = ((UNOP*)first)->op_first;
5090 const OP * const k2 = k1->op_sibling;
5092 switch (first->op_type)
5095 if (k2 && k2->op_type == OP_READLINE
5096 && (k2->op_flags & OPf_STACKED)
5097 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5099 warnop = k2->op_type;
5104 if (k1->op_type == OP_READDIR
5105 || k1->op_type == OP_GLOB
5106 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5107 || k1->op_type == OP_EACH)
5109 warnop = ((k1->op_type == OP_NULL)
5110 ? (OPCODE)k1->op_targ : k1->op_type);
5115 const line_t oldline = CopLINE(PL_curcop);
5116 CopLINE_set(PL_curcop, PL_parser->copline);
5117 Perl_warner(aTHX_ packWARN(WARN_MISC),
5118 "Value of %s%s can be \"0\"; test with defined()",
5120 ((warnop == OP_READLINE || warnop == OP_GLOB)
5121 ? " construct" : "() operator"));
5122 CopLINE_set(PL_curcop, oldline);
5129 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5130 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5132 NewOp(1101, logop, 1, LOGOP);
5134 logop->op_type = (OPCODE)type;
5135 logop->op_ppaddr = PL_ppaddr[type];
5136 logop->op_first = first;
5137 logop->op_flags = (U8)(flags | OPf_KIDS);
5138 logop->op_other = LINKLIST(other);
5139 logop->op_private = (U8)(1 | (flags >> 8));
5141 /* establish postfix order */
5142 logop->op_next = LINKLIST(first);
5143 first->op_next = (OP*)logop;
5144 first->op_sibling = other;
5146 CHECKOP(type,logop);
5148 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5155 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5157 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5158 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5159 will be set automatically, and, shifted up eight bits, the eight bits of
5160 C<op_private>, except that the bit with value 1 is automatically set.
5161 I<first> supplies the expression selecting between the two branches,
5162 and I<trueop> and I<falseop> supply the branches; they are consumed by
5163 this function and become part of the constructed op tree.
5169 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5177 PERL_ARGS_ASSERT_NEWCONDOP;
5180 return newLOGOP(OP_AND, 0, first, trueop);
5182 return newLOGOP(OP_OR, 0, first, falseop);
5184 scalarboolean(first);
5185 if ((cstop = search_const(first))) {
5186 /* Left or right arm of the conditional? */
5187 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5188 OP *live = left ? trueop : falseop;
5189 OP *const dead = left ? falseop : trueop;
5190 if (cstop->op_private & OPpCONST_BARE &&
5191 cstop->op_private & OPpCONST_STRICT) {
5192 no_bareword_allowed(cstop);
5195 /* This is all dead code when PERL_MAD is not defined. */
5196 live = newUNOP(OP_NULL, 0, live);
5197 op_getmad(first, live, 'C');
5198 op_getmad(dead, live, left ? 'e' : 't');
5203 if (live->op_type == OP_LEAVE)
5204 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5205 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5206 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5207 /* Mark the op as being unbindable with =~ */
5208 live->op_flags |= OPf_SPECIAL;
5211 NewOp(1101, logop, 1, LOGOP);
5212 logop->op_type = OP_COND_EXPR;
5213 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5214 logop->op_first = first;
5215 logop->op_flags = (U8)(flags | OPf_KIDS);
5216 logop->op_private = (U8)(1 | (flags >> 8));
5217 logop->op_other = LINKLIST(trueop);
5218 logop->op_next = LINKLIST(falseop);
5220 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5223 /* establish postfix order */
5224 start = LINKLIST(first);
5225 first->op_next = (OP*)logop;
5227 first->op_sibling = trueop;
5228 trueop->op_sibling = falseop;
5229 o = newUNOP(OP_NULL, 0, (OP*)logop);
5231 trueop->op_next = falseop->op_next = o;
5238 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5240 Constructs and returns a C<range> op, with subordinate C<flip> and
5241 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5242 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5243 for both the C<flip> and C<range> ops, except that the bit with value
5244 1 is automatically set. I<left> and I<right> supply the expressions
5245 controlling the endpoints of the range; they are consumed by this function
5246 and become part of the constructed op tree.
5252 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5261 PERL_ARGS_ASSERT_NEWRANGE;
5263 NewOp(1101, range, 1, LOGOP);
5265 range->op_type = OP_RANGE;
5266 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5267 range->op_first = left;
5268 range->op_flags = OPf_KIDS;
5269 leftstart = LINKLIST(left);
5270 range->op_other = LINKLIST(right);
5271 range->op_private = (U8)(1 | (flags >> 8));
5273 left->op_sibling = right;
5275 range->op_next = (OP*)range;
5276 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5277 flop = newUNOP(OP_FLOP, 0, flip);
5278 o = newUNOP(OP_NULL, 0, flop);
5280 range->op_next = leftstart;
5282 left->op_next = flip;
5283 right->op_next = flop;
5285 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5286 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5287 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5288 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5290 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5291 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5294 if (!flip->op_private || !flop->op_private)
5295 LINKLIST(o); /* blow off optimizer unless constant */
5301 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5303 Constructs, checks, and returns an op tree expressing a loop. This is
5304 only a loop in the control flow through the op tree; it does not have
5305 the heavyweight loop structure that allows exiting the loop by C<last>
5306 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5307 top-level op, except that some bits will be set automatically as required.
5308 I<expr> supplies the expression controlling loop iteration, and I<block>
5309 supplies the body of the loop; they are consumed by this function and
5310 become part of the constructed op tree. I<debuggable> is currently
5311 unused and should always be 1.
5317 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5322 const bool once = block && block->op_flags & OPf_SPECIAL &&
5323 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5325 PERL_UNUSED_ARG(debuggable);
5328 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5329 return block; /* do {} while 0 does once */
5330 if (expr->op_type == OP_READLINE
5331 || expr->op_type == OP_READDIR
5332 || expr->op_type == OP_GLOB
5333 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5334 expr = newUNOP(OP_DEFINED, 0,
5335 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5336 } else if (expr->op_flags & OPf_KIDS) {
5337 const OP * const k1 = ((UNOP*)expr)->op_first;
5338 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5339 switch (expr->op_type) {
5341 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5342 && (k2->op_flags & OPf_STACKED)
5343 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5344 expr = newUNOP(OP_DEFINED, 0, expr);
5348 if (k1 && (k1->op_type == OP_READDIR
5349 || k1->op_type == OP_GLOB
5350 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5351 || k1->op_type == OP_EACH))
5352 expr = newUNOP(OP_DEFINED, 0, expr);
5358 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5359 * op, in listop. This is wrong. [perl #27024] */
5361 block = newOP(OP_NULL, 0);
5362 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5363 o = new_logop(OP_AND, 0, &expr, &listop);
5366 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5368 if (once && o != listop)
5369 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5372 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5374 o->op_flags |= flags;
5376 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5381 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5383 Constructs, checks, and returns an op tree expressing a C<while> loop.
5384 This is a heavyweight loop, with structure that allows exiting the loop
5385 by C<last> and suchlike.
5387 I<loop> is an optional preconstructed C<enterloop> op to use in the
5388 loop; if it is null then a suitable op will be constructed automatically.
5389 I<expr> supplies the loop's controlling expression. I<block> supplies the
5390 main body of the loop, and I<cont> optionally supplies a C<continue> block
5391 that operates as a second half of the body. All of these optree inputs
5392 are consumed by this function and become part of the constructed op tree.
5394 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5395 op and, shifted up eight bits, the eight bits of C<op_private> for
5396 the C<leaveloop> op, except that (in both cases) some bits will be set
5397 automatically. I<debuggable> is currently unused and should always be 1.
5398 I<has_my> can be supplied as true to force the
5399 loop body to be enclosed in its own scope.
5405 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5406 OP *expr, OP *block, OP *cont, I32 has_my)
5415 PERL_UNUSED_ARG(debuggable);
5418 if (expr->op_type == OP_READLINE
5419 || expr->op_type == OP_READDIR
5420 || expr->op_type == OP_GLOB
5421 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5422 expr = newUNOP(OP_DEFINED, 0,
5423 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5424 } else if (expr->op_flags & OPf_KIDS) {
5425 const OP * const k1 = ((UNOP*)expr)->op_first;
5426 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5427 switch (expr->op_type) {
5429 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5430 && (k2->op_flags & OPf_STACKED)
5431 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5432 expr = newUNOP(OP_DEFINED, 0, expr);
5436 if (k1 && (k1->op_type == OP_READDIR
5437 || k1->op_type == OP_GLOB
5438 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5439 || k1->op_type == OP_EACH))
5440 expr = newUNOP(OP_DEFINED, 0, expr);
5447 block = newOP(OP_NULL, 0);
5448 else if (cont || has_my) {
5449 block = op_scope(block);
5453 next = LINKLIST(cont);
5456 OP * const unstack = newOP(OP_UNSTACK, 0);
5459 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5463 listop = op_append_list(OP_LINESEQ, block, cont);
5465 redo = LINKLIST(listop);
5469 o = new_logop(OP_AND, 0, &expr, &listop);
5470 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5471 op_free(expr); /* oops, it's a while (0) */
5473 return NULL; /* listop already freed by new_logop */
5476 ((LISTOP*)listop)->op_last->op_next =
5477 (o == listop ? redo : LINKLIST(o));
5483 NewOp(1101,loop,1,LOOP);
5484 loop->op_type = OP_ENTERLOOP;
5485 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5486 loop->op_private = 0;
5487 loop->op_next = (OP*)loop;
5490 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5492 loop->op_redoop = redo;
5493 loop->op_lastop = o;
5494 o->op_private |= loopflags;
5497 loop->op_nextop = next;
5499 loop->op_nextop = o;
5501 o->op_flags |= flags;
5502 o->op_private |= (flags >> 8);
5507 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5509 Constructs, checks, and returns an op tree expressing a C<foreach>
5510 loop (iteration through a list of values). This is a heavyweight loop,
5511 with structure that allows exiting the loop by C<last> and suchlike.
5513 I<sv> optionally supplies the variable that will be aliased to each
5514 item in turn; if null, it defaults to C<$_> (either lexical or global).
5515 I<expr> supplies the list of values to iterate over. I<block> supplies
5516 the main body of the loop, and I<cont> optionally supplies a C<continue>
5517 block that operates as a second half of the body. All of these optree
5518 inputs are consumed by this function and become part of the constructed
5521 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5522 op and, shifted up eight bits, the eight bits of C<op_private> for
5523 the C<leaveloop> op, except that (in both cases) some bits will be set
5530 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5535 PADOFFSET padoff = 0;
5540 PERL_ARGS_ASSERT_NEWFOROP;
5543 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5544 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5545 sv->op_type = OP_RV2GV;
5546 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5548 /* The op_type check is needed to prevent a possible segfault
5549 * if the loop variable is undeclared and 'strict vars' is in
5550 * effect. This is illegal but is nonetheless parsed, so we
5551 * may reach this point with an OP_CONST where we're expecting
5554 if (cUNOPx(sv)->op_first->op_type == OP_GV
5555 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5556 iterpflags |= OPpITER_DEF;
5558 else if (sv->op_type == OP_PADSV) { /* private variable */
5559 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5560 padoff = sv->op_targ;
5570 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5572 SV *const namesv = PAD_COMPNAME_SV(padoff);
5574 const char *const name = SvPV_const(namesv, len);
5576 if (len == 2 && name[0] == '$' && name[1] == '_')
5577 iterpflags |= OPpITER_DEF;
5581 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5582 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5583 sv = newGVOP(OP_GV, 0, PL_defgv);
5588 iterpflags |= OPpITER_DEF;
5590 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5591 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5592 iterflags |= OPf_STACKED;
5594 else if (expr->op_type == OP_NULL &&
5595 (expr->op_flags & OPf_KIDS) &&
5596 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5598 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5599 * set the STACKED flag to indicate that these values are to be
5600 * treated as min/max values by 'pp_iterinit'.
5602 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5603 LOGOP* const range = (LOGOP*) flip->op_first;
5604 OP* const left = range->op_first;
5605 OP* const right = left->op_sibling;
5608 range->op_flags &= ~OPf_KIDS;
5609 range->op_first = NULL;
5611 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5612 listop->op_first->op_next = range->op_next;
5613 left->op_next = range->op_other;
5614 right->op_next = (OP*)listop;
5615 listop->op_next = listop->op_first;
5618 op_getmad(expr,(OP*)listop,'O');
5622 expr = (OP*)(listop);
5624 iterflags |= OPf_STACKED;
5627 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5630 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5631 op_append_elem(OP_LIST, expr, scalar(sv))));
5632 assert(!loop->op_next);
5633 /* for my $x () sets OPpLVAL_INTRO;
5634 * for our $x () sets OPpOUR_INTRO */
5635 loop->op_private = (U8)iterpflags;
5636 #ifdef PL_OP_SLAB_ALLOC
5639 NewOp(1234,tmp,1,LOOP);
5640 Copy(loop,tmp,1,LISTOP);
5641 S_op_destroy(aTHX_ (OP*)loop);
5645 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5647 loop->op_targ = padoff;
5648 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5650 op_getmad(madsv, (OP*)loop, 'v');
5655 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5657 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5658 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5659 determining the target of the op; it is consumed by this function and
5660 become part of the constructed op tree.
5666 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5671 PERL_ARGS_ASSERT_NEWLOOPEX;
5673 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5675 if (type != OP_GOTO || label->op_type == OP_CONST) {
5676 /* "last()" means "last" */
5677 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5678 o = newOP(type, OPf_SPECIAL);
5680 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5681 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5685 op_getmad(label,o,'L');
5691 /* Check whether it's going to be a goto &function */
5692 if (label->op_type == OP_ENTERSUB
5693 && !(label->op_flags & OPf_STACKED))
5694 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5695 o = newUNOP(type, OPf_STACKED, label);
5697 PL_hints |= HINT_BLOCK_SCOPE;
5701 /* if the condition is a literal array or hash
5702 (or @{ ... } etc), make a reference to it.
5705 S_ref_array_or_hash(pTHX_ OP *cond)
5708 && (cond->op_type == OP_RV2AV
5709 || cond->op_type == OP_PADAV
5710 || cond->op_type == OP_RV2HV
5711 || cond->op_type == OP_PADHV))
5713 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5716 && (cond->op_type == OP_ASLICE
5717 || cond->op_type == OP_HSLICE)) {
5719 /* anonlist now needs a list from this op, was previously used in
5721 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5722 cond->op_flags |= OPf_WANT_LIST;
5724 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5731 /* These construct the optree fragments representing given()
5734 entergiven and enterwhen are LOGOPs; the op_other pointer
5735 points up to the associated leave op. We need this so we
5736 can put it in the context and make break/continue work.
5737 (Also, of course, pp_enterwhen will jump straight to
5738 op_other if the match fails.)
5742 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5743 I32 enter_opcode, I32 leave_opcode,
5744 PADOFFSET entertarg)
5750 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5752 NewOp(1101, enterop, 1, LOGOP);
5753 enterop->op_type = (Optype)enter_opcode;
5754 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5755 enterop->op_flags = (U8) OPf_KIDS;
5756 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5757 enterop->op_private = 0;
5759 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5762 enterop->op_first = scalar(cond);
5763 cond->op_sibling = block;
5765 o->op_next = LINKLIST(cond);
5766 cond->op_next = (OP *) enterop;
5769 /* This is a default {} block */
5770 enterop->op_first = block;
5771 enterop->op_flags |= OPf_SPECIAL;
5773 o->op_next = (OP *) enterop;
5776 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5777 entergiven and enterwhen both
5780 enterop->op_next = LINKLIST(block);
5781 block->op_next = enterop->op_other = o;
5786 /* Does this look like a boolean operation? For these purposes
5787 a boolean operation is:
5788 - a subroutine call [*]
5789 - a logical connective
5790 - a comparison operator
5791 - a filetest operator, with the exception of -s -M -A -C
5792 - defined(), exists() or eof()
5793 - /$re/ or $foo =~ /$re/
5795 [*] possibly surprising
5798 S_looks_like_bool(pTHX_ const OP *o)
5802 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5804 switch(o->op_type) {
5807 return looks_like_bool(cLOGOPo->op_first);
5811 looks_like_bool(cLOGOPo->op_first)
5812 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5817 o->op_flags & OPf_KIDS
5818 && looks_like_bool(cUNOPo->op_first));
5822 case OP_NOT: case OP_XOR:
5824 case OP_EQ: case OP_NE: case OP_LT:
5825 case OP_GT: case OP_LE: case OP_GE:
5827 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5828 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5830 case OP_SEQ: case OP_SNE: case OP_SLT:
5831 case OP_SGT: case OP_SLE: case OP_SGE:
5835 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5836 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5837 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5838 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5839 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5840 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5841 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5842 case OP_FTTEXT: case OP_FTBINARY:
5844 case OP_DEFINED: case OP_EXISTS:
5845 case OP_MATCH: case OP_EOF:
5852 /* Detect comparisons that have been optimized away */
5853 if (cSVOPo->op_sv == &PL_sv_yes
5854 || cSVOPo->op_sv == &PL_sv_no)
5867 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5869 Constructs, checks, and returns an op tree expressing a C<given> block.
5870 I<cond> supplies the expression that will be locally assigned to a lexical
5871 variable, and I<block> supplies the body of the C<given> construct; they
5872 are consumed by this function and become part of the constructed op tree.
5873 I<defsv_off> is the pad offset of the scalar lexical variable that will
5880 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5883 PERL_ARGS_ASSERT_NEWGIVENOP;
5884 return newGIVWHENOP(
5885 ref_array_or_hash(cond),
5887 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5892 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5894 Constructs, checks, and returns an op tree expressing a C<when> block.
5895 I<cond> supplies the test expression, and I<block> supplies the block
5896 that will be executed if the test evaluates to true; they are consumed
5897 by this function and become part of the constructed op tree. I<cond>
5898 will be interpreted DWIMically, often as a comparison against C<$_>,
5899 and may be null to generate a C<default> block.
5905 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5907 const bool cond_llb = (!cond || looks_like_bool(cond));
5910 PERL_ARGS_ASSERT_NEWWHENOP;
5915 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5917 scalar(ref_array_or_hash(cond)));
5920 return newGIVWHENOP(
5922 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5923 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5927 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5930 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5932 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5933 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5934 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5935 || (p && (len != SvCUR(cv) /* Not the same length. */
5936 || memNE(p, SvPVX_const(cv), len))))
5937 && ckWARN_d(WARN_PROTOTYPE)) {
5938 SV* const msg = sv_newmortal();
5942 gv_efullname3(name = sv_newmortal(), gv, NULL);
5943 sv_setpvs(msg, "Prototype mismatch:");
5945 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5947 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5949 sv_catpvs(msg, ": none");
5950 sv_catpvs(msg, " vs ");
5952 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5954 sv_catpvs(msg, "none");
5955 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5959 static void const_sv_xsub(pTHX_ CV* cv);
5963 =head1 Optree Manipulation Functions
5965 =for apidoc cv_const_sv
5967 If C<cv> is a constant sub eligible for inlining. returns the constant
5968 value returned by the sub. Otherwise, returns NULL.
5970 Constant subs can be created with C<newCONSTSUB> or as described in
5971 L<perlsub/"Constant Functions">.
5976 Perl_cv_const_sv(pTHX_ const CV *const cv)
5978 PERL_UNUSED_CONTEXT;
5981 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5983 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5986 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5987 * Can be called in 3 ways:
5990 * look for a single OP_CONST with attached value: return the value
5992 * cv && CvCLONE(cv) && !CvCONST(cv)
5994 * examine the clone prototype, and if contains only a single
5995 * OP_CONST referencing a pad const, or a single PADSV referencing
5996 * an outer lexical, return a non-zero value to indicate the CV is
5997 * a candidate for "constizing" at clone time
6001 * We have just cloned an anon prototype that was marked as a const
6002 * candidiate. Try to grab the current value, and in the case of
6003 * PADSV, ignore it if it has multiple references. Return the value.
6007 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6018 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6019 o = cLISTOPo->op_first->op_sibling;
6021 for (; o; o = o->op_next) {
6022 const OPCODE type = o->op_type;
6024 if (sv && o->op_next == o)
6026 if (o->op_next != o) {
6027 if (type == OP_NEXTSTATE
6028 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6029 || type == OP_PUSHMARK)
6031 if (type == OP_DBSTATE)
6034 if (type == OP_LEAVESUB || type == OP_RETURN)
6038 if (type == OP_CONST && cSVOPo->op_sv)
6040 else if (cv && type == OP_CONST) {
6041 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6045 else if (cv && type == OP_PADSV) {
6046 if (CvCONST(cv)) { /* newly cloned anon */
6047 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6048 /* the candidate should have 1 ref from this pad and 1 ref
6049 * from the parent */
6050 if (!sv || SvREFCNT(sv) != 2)
6057 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6058 sv = &PL_sv_undef; /* an arbitrary non-null value */
6073 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6076 /* This would be the return value, but the return cannot be reached. */
6077 OP* pegop = newOP(OP_NULL, 0);
6080 PERL_UNUSED_ARG(floor);
6090 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6092 NORETURN_FUNCTION_END;
6097 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6102 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6103 register CV *cv = NULL;
6105 /* If the subroutine has no body, no attributes, and no builtin attributes
6106 then it's just a sub declaration, and we may be able to get away with
6107 storing with a placeholder scalar in the symbol table, rather than a
6108 full GV and CV. If anything is present then it will take a full CV to
6110 const I32 gv_fetch_flags
6111 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6113 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6114 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6118 assert(proto->op_type == OP_CONST);
6119 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6125 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6127 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6128 SV * const sv = sv_newmortal();
6129 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6130 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6131 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6132 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6134 } else if (PL_curstash) {
6135 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6138 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6142 if (!PL_madskills) {
6151 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6152 maximum a prototype before. */
6153 if (SvTYPE(gv) > SVt_NULL) {
6154 if (!SvPOK((const SV *)gv)
6155 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6157 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6159 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6162 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6164 sv_setiv(MUTABLE_SV(gv), -1);
6166 SvREFCNT_dec(PL_compcv);
6167 cv = PL_compcv = NULL;
6171 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6173 if (!block || !ps || *ps || attrs
6174 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6176 || block->op_type == OP_NULL
6181 const_sv = op_const_sv(block, NULL);
6184 const bool exists = CvROOT(cv) || CvXSUB(cv);
6186 /* if the subroutine doesn't exist and wasn't pre-declared
6187 * with a prototype, assume it will be AUTOLOADed,
6188 * skipping the prototype check
6190 if (exists || SvPOK(cv))
6191 cv_ckproto_len(cv, gv, ps, ps_len);
6192 /* already defined (or promised)? */
6193 if (exists || GvASSUMECV(gv)) {
6196 || block->op_type == OP_NULL
6199 if (CvFLAGS(PL_compcv)) {
6200 /* might have had built-in attrs applied */
6201 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6202 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6203 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6205 /* just a "sub foo;" when &foo is already defined */
6206 SAVEFREESV(PL_compcv);
6211 && block->op_type != OP_NULL
6214 if (ckWARN(WARN_REDEFINE)
6216 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6218 const line_t oldline = CopLINE(PL_curcop);
6219 if (PL_parser && PL_parser->copline != NOLINE)
6220 CopLINE_set(PL_curcop, PL_parser->copline);
6221 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6222 CvCONST(cv) ? "Constant subroutine %s redefined"
6223 : "Subroutine %s redefined", name);
6224 CopLINE_set(PL_curcop, oldline);
6227 if (!PL_minus_c) /* keep old one around for madskills */
6230 /* (PL_madskills unset in used file.) */
6238 SvREFCNT_inc_simple_void_NN(const_sv);
6240 assert(!CvROOT(cv) && !CvCONST(cv));
6241 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6242 CvXSUBANY(cv).any_ptr = const_sv;
6243 CvXSUB(cv) = const_sv_xsub;
6249 cv = newCONSTSUB(NULL, name, const_sv);
6251 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6252 (CvGV(cv) && GvSTASH(CvGV(cv)))
6261 SvREFCNT_dec(PL_compcv);
6265 if (cv) { /* must reuse cv if autoloaded */
6266 /* transfer PL_compcv to cv */
6269 && block->op_type != OP_NULL
6272 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6273 AV *const temp_av = CvPADLIST(cv);
6274 CV *const temp_cv = CvOUTSIDE(cv);
6276 assert(!CvWEAKOUTSIDE(cv));
6277 assert(!CvCVGV_RC(cv));
6278 assert(CvGV(cv) == gv);
6281 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6282 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6283 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6284 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6285 CvOUTSIDE(PL_compcv) = temp_cv;
6286 CvPADLIST(PL_compcv) = temp_av;
6289 if (CvFILE(cv) && !CvISXSUB(cv)) {
6290 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
6291 Safefree(CvFILE(cv));
6294 CvFILE_set_from_cop(cv, PL_curcop);
6295 CvSTASH_set(cv, PL_curstash);
6297 /* inner references to PL_compcv must be fixed up ... */
6298 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6299 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6300 ++PL_sub_generation;
6303 /* Might have had built-in attributes applied -- propagate them. */
6304 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6306 /* ... before we throw it away */
6307 SvREFCNT_dec(PL_compcv);
6315 if (strEQ(name, "import")) {
6316 PL_formfeed = MUTABLE_SV(cv);
6317 /* diag_listed_as: SKIPME */
6318 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6322 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6327 CvFILE_set_from_cop(cv, PL_curcop);
6328 CvSTASH_set(cv, PL_curstash);
6331 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6332 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6333 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6337 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6339 if (PL_parser && PL_parser->error_count) {
6343 const char *s = strrchr(name, ':');
6345 if (strEQ(s, "BEGIN")) {
6346 const char not_safe[] =
6347 "BEGIN not safe after errors--compilation aborted";
6348 if (PL_in_eval & EVAL_KEEPERR)
6349 Perl_croak(aTHX_ not_safe);
6351 /* force display of errors found but not reported */
6352 sv_catpv(ERRSV, not_safe);
6353 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6362 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6363 the debugger could be able to set a breakpoint in, so signal to
6364 pp_entereval that it should not throw away any saved lines at scope
6367 PL_breakable_sub_gen++;
6369 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6370 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6371 block->op_attached = 1;
6374 /* This makes sub {}; work as expected. */
6375 if (block->op_type == OP_STUB) {
6376 OP* const newblock = newSTATEOP(0, NULL, 0);
6378 op_getmad(block,newblock,'B');
6385 block->op_attached = 1;
6386 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6388 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6389 OpREFCNT_set(CvROOT(cv), 1);
6390 CvSTART(cv) = LINKLIST(CvROOT(cv));
6391 CvROOT(cv)->op_next = 0;
6392 CALL_PEEP(CvSTART(cv));
6394 /* now that optimizer has done its work, adjust pad values */
6396 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6399 assert(!CvCONST(cv));
6400 if (ps && !*ps && op_const_sv(block, cv))
6405 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6406 SV * const tmpstr = sv_newmortal();
6407 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6408 GV_ADDMULTI, SVt_PVHV);
6410 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6413 (long)CopLINE(PL_curcop));
6414 gv_efullname3(tmpstr, gv, NULL);
6415 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6416 SvCUR(tmpstr), sv, 0);
6417 hv = GvHVn(db_postponed);
6418 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6419 CV * const pcv = GvCV(db_postponed);
6425 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6430 if (name && ! (PL_parser && PL_parser->error_count))
6431 process_special_blocks(name, gv, cv);
6436 PL_parser->copline = NOLINE;
6442 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6445 const char *const colon = strrchr(fullname,':');
6446 const char *const name = colon ? colon + 1 : fullname;
6448 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6451 if (strEQ(name, "BEGIN")) {
6452 const I32 oldscope = PL_scopestack_ix;
6454 SAVECOPFILE(&PL_compiling);
6455 SAVECOPLINE(&PL_compiling);
6457 DEBUG_x( dump_sub(gv) );
6458 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6459 GvCV(gv) = 0; /* cv has been hijacked */
6460 call_list(oldscope, PL_beginav);
6462 PL_curcop = &PL_compiling;
6463 CopHINTS_set(&PL_compiling, PL_hints);
6470 if strEQ(name, "END") {
6471 DEBUG_x( dump_sub(gv) );
6472 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6475 } else if (*name == 'U') {
6476 if (strEQ(name, "UNITCHECK")) {
6477 /* It's never too late to run a unitcheck block */
6478 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6482 } else if (*name == 'C') {
6483 if (strEQ(name, "CHECK")) {
6485 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6486 "Too late to run CHECK block");
6487 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6491 } else if (*name == 'I') {
6492 if (strEQ(name, "INIT")) {
6494 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6495 "Too late to run INIT block");
6496 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6502 DEBUG_x( dump_sub(gv) );
6503 GvCV(gv) = 0; /* cv has been hijacked */
6508 =for apidoc newCONSTSUB
6510 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6511 eligible for inlining at compile-time.
6513 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6514 which won't be called if used as a destructor, but will suppress the overhead
6515 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6522 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6527 const char *const file = CopFILE(PL_curcop);
6529 SV *const temp_sv = CopFILESV(PL_curcop);
6530 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6535 if (IN_PERL_RUNTIME) {
6536 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6537 * an op shared between threads. Use a non-shared COP for our
6539 SAVEVPTR(PL_curcop);
6540 PL_curcop = &PL_compiling;
6542 SAVECOPLINE(PL_curcop);
6543 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6546 PL_hints &= ~HINT_BLOCK_SCOPE;
6549 SAVESPTR(PL_curstash);
6550 SAVECOPSTASH(PL_curcop);
6551 PL_curstash = stash;
6552 CopSTASH_set(PL_curcop,stash);
6555 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6556 and so doesn't get free()d. (It's expected to be from the C pre-
6557 processor __FILE__ directive). But we need a dynamically allocated one,
6558 and we need it to get freed. */
6559 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6560 XS_DYNAMIC_FILENAME);
6561 CvXSUBANY(cv).any_ptr = sv;
6566 CopSTASH_free(PL_curcop);
6574 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6575 const char *const filename, const char *const proto,
6578 CV *cv = newXS(name, subaddr, filename);
6580 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6582 if (flags & XS_DYNAMIC_FILENAME) {
6583 /* We need to "make arrangements" (ie cheat) to ensure that the
6584 filename lasts as long as the PVCV we just created, but also doesn't
6586 STRLEN filename_len = strlen(filename);
6587 STRLEN proto_and_file_len = filename_len;
6588 char *proto_and_file;
6592 proto_len = strlen(proto);
6593 proto_and_file_len += proto_len;
6595 Newx(proto_and_file, proto_and_file_len + 1, char);
6596 Copy(proto, proto_and_file, proto_len, char);
6597 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6600 proto_and_file = savepvn(filename, filename_len);
6603 /* This gets free()d. :-) */
6604 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6605 SV_HAS_TRAILING_NUL);
6607 /* This gives us the correct prototype, rather than one with the
6608 file name appended. */
6609 SvCUR_set(cv, proto_len);
6613 CvFILE(cv) = proto_and_file + proto_len;
6615 sv_setpv(MUTABLE_SV(cv), proto);
6621 =for apidoc U||newXS
6623 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6624 static storage, as it is used directly as CvFILE(), without a copy being made.
6630 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6633 GV * const gv = gv_fetchpv(name ? name :
6634 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6635 GV_ADDMULTI, SVt_PVCV);
6638 PERL_ARGS_ASSERT_NEWXS;
6641 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6643 if ((cv = (name ? GvCV(gv) : NULL))) {
6645 /* just a cached method */
6649 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6650 /* already defined (or promised) */
6651 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6652 if (ckWARN(WARN_REDEFINE)) {
6653 GV * const gvcv = CvGV(cv);
6655 HV * const stash = GvSTASH(gvcv);
6657 const char *redefined_name = HvNAME_get(stash);
6658 if ( strEQ(redefined_name,"autouse") ) {
6659 const line_t oldline = CopLINE(PL_curcop);
6660 if (PL_parser && PL_parser->copline != NOLINE)
6661 CopLINE_set(PL_curcop, PL_parser->copline);
6662 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6663 CvCONST(cv) ? "Constant subroutine %s redefined"
6664 : "Subroutine %s redefined"
6666 CopLINE_set(PL_curcop, oldline);
6676 if (cv) /* must reuse cv if autoloaded */
6679 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6683 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6689 (void)gv_fetchfile(filename);
6690 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6691 an external constant string */
6693 CvXSUB(cv) = subaddr;
6696 process_special_blocks(name, gv, cv);
6706 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6711 OP* pegop = newOP(OP_NULL, 0);
6715 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6716 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6719 if ((cv = GvFORM(gv))) {
6720 if (ckWARN(WARN_REDEFINE)) {
6721 const line_t oldline = CopLINE(PL_curcop);
6722 if (PL_parser && PL_parser->copline != NOLINE)
6723 CopLINE_set(PL_curcop, PL_parser->copline);
6725 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6726 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6728 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6729 "Format STDOUT redefined");
6731 CopLINE_set(PL_curcop, oldline);
6738 CvFILE_set_from_cop(cv, PL_curcop);
6741 pad_tidy(padtidy_FORMAT);
6742 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6743 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6744 OpREFCNT_set(CvROOT(cv), 1);
6745 CvSTART(cv) = LINKLIST(CvROOT(cv));
6746 CvROOT(cv)->op_next = 0;
6747 CALL_PEEP(CvSTART(cv));
6749 op_getmad(o,pegop,'n');
6750 op_getmad_weak(block, pegop, 'b');
6755 PL_parser->copline = NOLINE;
6763 Perl_newANONLIST(pTHX_ OP *o)
6765 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6769 Perl_newANONHASH(pTHX_ OP *o)
6771 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6775 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6777 return newANONATTRSUB(floor, proto, NULL, block);
6781 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6783 return newUNOP(OP_REFGEN, 0,
6784 newSVOP(OP_ANONCODE, 0,
6785 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6789 Perl_oopsAV(pTHX_ OP *o)
6793 PERL_ARGS_ASSERT_OOPSAV;
6795 switch (o->op_type) {
6797 o->op_type = OP_PADAV;
6798 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6799 return ref(o, OP_RV2AV);
6802 o->op_type = OP_RV2AV;
6803 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6808 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6815 Perl_oopsHV(pTHX_ OP *o)
6819 PERL_ARGS_ASSERT_OOPSHV;
6821 switch (o->op_type) {
6824 o->op_type = OP_PADHV;
6825 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6826 return ref(o, OP_RV2HV);
6830 o->op_type = OP_RV2HV;
6831 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6836 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6843 Perl_newAVREF(pTHX_ OP *o)
6847 PERL_ARGS_ASSERT_NEWAVREF;
6849 if (o->op_type == OP_PADANY) {
6850 o->op_type = OP_PADAV;
6851 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6854 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6855 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6856 "Using an array as a reference is deprecated");
6858 return newUNOP(OP_RV2AV, 0, scalar(o));
6862 Perl_newGVREF(pTHX_ I32 type, OP *o)
6864 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6865 return newUNOP(OP_NULL, 0, o);
6866 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6870 Perl_newHVREF(pTHX_ OP *o)
6874 PERL_ARGS_ASSERT_NEWHVREF;
6876 if (o->op_type == OP_PADANY) {
6877 o->op_type = OP_PADHV;
6878 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6881 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6882 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6883 "Using a hash as a reference is deprecated");
6885 return newUNOP(OP_RV2HV, 0, scalar(o));
6889 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6891 return newUNOP(OP_RV2CV, flags, scalar(o));
6895 Perl_newSVREF(pTHX_ OP *o)
6899 PERL_ARGS_ASSERT_NEWSVREF;
6901 if (o->op_type == OP_PADANY) {
6902 o->op_type = OP_PADSV;
6903 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6906 return newUNOP(OP_RV2SV, 0, scalar(o));
6909 /* Check routines. See the comments at the top of this file for details
6910 * on when these are called */
6913 Perl_ck_anoncode(pTHX_ OP *o)
6915 PERL_ARGS_ASSERT_CK_ANONCODE;
6917 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6919 cSVOPo->op_sv = NULL;
6924 Perl_ck_bitop(pTHX_ OP *o)
6928 PERL_ARGS_ASSERT_CK_BITOP;
6930 #define OP_IS_NUMCOMPARE(op) \
6931 ((op) == OP_LT || (op) == OP_I_LT || \
6932 (op) == OP_GT || (op) == OP_I_GT || \
6933 (op) == OP_LE || (op) == OP_I_LE || \
6934 (op) == OP_GE || (op) == OP_I_GE || \
6935 (op) == OP_EQ || (op) == OP_I_EQ || \
6936 (op) == OP_NE || (op) == OP_I_NE || \
6937 (op) == OP_NCMP || (op) == OP_I_NCMP)
6938 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6939 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6940 && (o->op_type == OP_BIT_OR
6941 || o->op_type == OP_BIT_AND
6942 || o->op_type == OP_BIT_XOR))
6944 const OP * const left = cBINOPo->op_first;
6945 const OP * const right = left->op_sibling;
6946 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6947 (left->op_flags & OPf_PARENS) == 0) ||
6948 (OP_IS_NUMCOMPARE(right->op_type) &&
6949 (right->op_flags & OPf_PARENS) == 0))
6950 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6951 "Possible precedence problem on bitwise %c operator",
6952 o->op_type == OP_BIT_OR ? '|'
6953 : o->op_type == OP_BIT_AND ? '&' : '^'
6960 Perl_ck_concat(pTHX_ OP *o)
6962 const OP * const kid = cUNOPo->op_first;
6964 PERL_ARGS_ASSERT_CK_CONCAT;
6965 PERL_UNUSED_CONTEXT;
6967 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6968 !(kUNOP->op_first->op_flags & OPf_MOD))
6969 o->op_flags |= OPf_STACKED;
6974 Perl_ck_spair(pTHX_ OP *o)
6978 PERL_ARGS_ASSERT_CK_SPAIR;
6980 if (o->op_flags & OPf_KIDS) {
6983 const OPCODE type = o->op_type;
6984 o = modkids(ck_fun(o), type);
6985 kid = cUNOPo->op_first;
6986 newop = kUNOP->op_first->op_sibling;
6988 const OPCODE type = newop->op_type;
6989 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6990 type == OP_PADAV || type == OP_PADHV ||
6991 type == OP_RV2AV || type == OP_RV2HV)
6995 op_getmad(kUNOP->op_first,newop,'K');
6997 op_free(kUNOP->op_first);
6999 kUNOP->op_first = newop;
7001 o->op_ppaddr = PL_ppaddr[++o->op_type];
7006 Perl_ck_delete(pTHX_ OP *o)
7008 PERL_ARGS_ASSERT_CK_DELETE;
7012 if (o->op_flags & OPf_KIDS) {
7013 OP * const kid = cUNOPo->op_first;
7014 switch (kid->op_type) {
7016 o->op_flags |= OPf_SPECIAL;
7019 o->op_private |= OPpSLICE;
7022 o->op_flags |= OPf_SPECIAL;
7027 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7030 if (kid->op_private & OPpLVAL_INTRO)
7031 o->op_private |= OPpLVAL_INTRO;
7038 Perl_ck_die(pTHX_ OP *o)
7040 PERL_ARGS_ASSERT_CK_DIE;
7043 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7049 Perl_ck_eof(pTHX_ OP *o)
7053 PERL_ARGS_ASSERT_CK_EOF;
7055 if (o->op_flags & OPf_KIDS) {
7056 if (cLISTOPo->op_first->op_type == OP_STUB) {
7058 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7060 op_getmad(o,newop,'O');
7072 Perl_ck_eval(pTHX_ OP *o)
7076 PERL_ARGS_ASSERT_CK_EVAL;
7078 PL_hints |= HINT_BLOCK_SCOPE;
7079 if (o->op_flags & OPf_KIDS) {
7080 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7083 o->op_flags &= ~OPf_KIDS;
7086 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7092 cUNOPo->op_first = 0;
7097 NewOp(1101, enter, 1, LOGOP);
7098 enter->op_type = OP_ENTERTRY;
7099 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7100 enter->op_private = 0;
7102 /* establish postfix order */
7103 enter->op_next = (OP*)enter;
7105 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7106 o->op_type = OP_LEAVETRY;
7107 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7108 enter->op_other = o;
7109 op_getmad(oldo,o,'O');
7123 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7124 op_getmad(oldo,o,'O');
7126 o->op_targ = (PADOFFSET)PL_hints;
7127 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7128 /* Store a copy of %^H that pp_entereval can pick up. */
7129 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7130 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7131 cUNOPo->op_first->op_sibling = hhop;
7132 o->op_private |= OPpEVAL_HAS_HH;
7138 Perl_ck_exit(pTHX_ OP *o)
7140 PERL_ARGS_ASSERT_CK_EXIT;
7143 HV * const table = GvHV(PL_hintgv);
7145 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7146 if (svp && *svp && SvTRUE(*svp))
7147 o->op_private |= OPpEXIT_VMSISH;
7149 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7155 Perl_ck_exec(pTHX_ OP *o)
7157 PERL_ARGS_ASSERT_CK_EXEC;
7159 if (o->op_flags & OPf_STACKED) {
7162 kid = cUNOPo->op_first->op_sibling;
7163 if (kid->op_type == OP_RV2GV)
7172 Perl_ck_exists(pTHX_ OP *o)
7176 PERL_ARGS_ASSERT_CK_EXISTS;
7179 if (o->op_flags & OPf_KIDS) {
7180 OP * const kid = cUNOPo->op_first;
7181 if (kid->op_type == OP_ENTERSUB) {
7182 (void) ref(kid, o->op_type);
7183 if (kid->op_type != OP_RV2CV
7184 && !(PL_parser && PL_parser->error_count))
7185 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7187 o->op_private |= OPpEXISTS_SUB;
7189 else if (kid->op_type == OP_AELEM)
7190 o->op_flags |= OPf_SPECIAL;
7191 else if (kid->op_type != OP_HELEM)
7192 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7200 Perl_ck_rvconst(pTHX_ register OP *o)
7203 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7205 PERL_ARGS_ASSERT_CK_RVCONST;
7207 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7208 if (o->op_type == OP_RV2CV)
7209 o->op_private &= ~1;
7211 if (kid->op_type == OP_CONST) {
7214 SV * const kidsv = kid->op_sv;
7216 /* Is it a constant from cv_const_sv()? */
7217 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7218 SV * const rsv = SvRV(kidsv);
7219 const svtype type = SvTYPE(rsv);
7220 const char *badtype = NULL;
7222 switch (o->op_type) {
7224 if (type > SVt_PVMG)
7225 badtype = "a SCALAR";
7228 if (type != SVt_PVAV)
7229 badtype = "an ARRAY";
7232 if (type != SVt_PVHV)
7236 if (type != SVt_PVCV)
7241 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7244 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7245 const char *badthing;
7246 switch (o->op_type) {
7248 badthing = "a SCALAR";
7251 badthing = "an ARRAY";
7254 badthing = "a HASH";
7262 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7263 SVfARG(kidsv), badthing);
7266 * This is a little tricky. We only want to add the symbol if we
7267 * didn't add it in the lexer. Otherwise we get duplicate strict
7268 * warnings. But if we didn't add it in the lexer, we must at
7269 * least pretend like we wanted to add it even if it existed before,
7270 * or we get possible typo warnings. OPpCONST_ENTERED says
7271 * whether the lexer already added THIS instance of this symbol.
7273 iscv = (o->op_type == OP_RV2CV) * 2;
7275 gv = gv_fetchsv(kidsv,
7276 iscv | !(kid->op_private & OPpCONST_ENTERED),
7279 : o->op_type == OP_RV2SV
7281 : o->op_type == OP_RV2AV
7283 : o->op_type == OP_RV2HV
7286 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7288 kid->op_type = OP_GV;
7289 SvREFCNT_dec(kid->op_sv);
7291 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7292 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7293 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7295 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7297 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7299 kid->op_private = 0;
7300 kid->op_ppaddr = PL_ppaddr[OP_GV];
7301 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7309 Perl_ck_ftst(pTHX_ OP *o)
7312 const I32 type = o->op_type;
7314 PERL_ARGS_ASSERT_CK_FTST;
7316 if (o->op_flags & OPf_REF) {
7319 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7320 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7321 const OPCODE kidtype = kid->op_type;
7323 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7324 OP * const newop = newGVOP(type, OPf_REF,
7325 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7327 op_getmad(o,newop,'O');
7333 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7334 o->op_private |= OPpFT_ACCESS;
7335 if (PL_check[kidtype] == Perl_ck_ftst
7336 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7337 o->op_private |= OPpFT_STACKED;
7345 if (type == OP_FTTTY)
7346 o = newGVOP(type, OPf_REF, PL_stdingv);
7348 o = newUNOP(type, 0, newDEFSVOP());
7349 op_getmad(oldo,o,'O');
7355 Perl_ck_fun(pTHX_ OP *o)
7358 const int type = o->op_type;
7359 register I32 oa = PL_opargs[type] >> OASHIFT;
7361 PERL_ARGS_ASSERT_CK_FUN;
7363 if (o->op_flags & OPf_STACKED) {
7364 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7367 return no_fh_allowed(o);
7370 if (o->op_flags & OPf_KIDS) {
7371 OP **tokid = &cLISTOPo->op_first;
7372 register OP *kid = cLISTOPo->op_first;
7376 if (kid->op_type == OP_PUSHMARK ||
7377 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7379 tokid = &kid->op_sibling;
7380 kid = kid->op_sibling;
7382 if (!kid && PL_opargs[type] & OA_DEFGV)
7383 *tokid = kid = newDEFSVOP();
7387 sibl = kid->op_sibling;
7389 if (!sibl && kid->op_type == OP_STUB) {
7396 /* list seen where single (scalar) arg expected? */
7397 if (numargs == 1 && !(oa >> 4)
7398 && kid->op_type == OP_LIST && type != OP_SCALAR)
7400 return too_many_arguments(o,PL_op_desc[type]);
7413 if ((type == OP_PUSH || type == OP_UNSHIFT)
7414 && !kid->op_sibling)
7415 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7416 "Useless use of %s with no values",
7419 if (kid->op_type == OP_CONST &&
7420 (kid->op_private & OPpCONST_BARE))
7422 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7423 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7424 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7425 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7426 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7428 op_getmad(kid,newop,'K');
7433 kid->op_sibling = sibl;
7436 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7437 bad_type(numargs, "array", PL_op_desc[type], kid);
7438 op_lvalue(kid, type);
7441 if (kid->op_type == OP_CONST &&
7442 (kid->op_private & OPpCONST_BARE))
7444 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7445 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7446 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7447 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7448 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7450 op_getmad(kid,newop,'K');
7455 kid->op_sibling = sibl;
7458 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7459 bad_type(numargs, "hash", PL_op_desc[type], kid);
7460 op_lvalue(kid, type);
7464 OP * const newop = newUNOP(OP_NULL, 0, kid);
7465 kid->op_sibling = 0;
7467 newop->op_next = newop;
7469 kid->op_sibling = sibl;
7474 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7475 if (kid->op_type == OP_CONST &&
7476 (kid->op_private & OPpCONST_BARE))
7478 OP * const newop = newGVOP(OP_GV, 0,
7479 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7480 if (!(o->op_private & 1) && /* if not unop */
7481 kid == cLISTOPo->op_last)
7482 cLISTOPo->op_last = newop;
7484 op_getmad(kid,newop,'K');
7490 else if (kid->op_type == OP_READLINE) {
7491 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7492 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7495 I32 flags = OPf_SPECIAL;
7499 /* is this op a FH constructor? */
7500 if (is_handle_constructor(o,numargs)) {
7501 const char *name = NULL;
7505 /* Set a flag to tell rv2gv to vivify
7506 * need to "prove" flag does not mean something
7507 * else already - NI-S 1999/05/07
7510 if (kid->op_type == OP_PADSV) {
7512 = PAD_COMPNAME_SV(kid->op_targ);
7513 name = SvPV_const(namesv, len);
7515 else if (kid->op_type == OP_RV2SV
7516 && kUNOP->op_first->op_type == OP_GV)
7518 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7520 len = GvNAMELEN(gv);
7522 else if (kid->op_type == OP_AELEM
7523 || kid->op_type == OP_HELEM)
7526 OP *op = ((BINOP*)kid)->op_first;
7530 const char * const a =
7531 kid->op_type == OP_AELEM ?
7533 if (((op->op_type == OP_RV2AV) ||
7534 (op->op_type == OP_RV2HV)) &&
7535 (firstop = ((UNOP*)op)->op_first) &&
7536 (firstop->op_type == OP_GV)) {
7537 /* packagevar $a[] or $h{} */
7538 GV * const gv = cGVOPx_gv(firstop);
7546 else if (op->op_type == OP_PADAV
7547 || op->op_type == OP_PADHV) {
7548 /* lexicalvar $a[] or $h{} */
7549 const char * const padname =
7550 PAD_COMPNAME_PV(op->op_targ);
7559 name = SvPV_const(tmpstr, len);
7564 name = "__ANONIO__";
7567 op_lvalue(kid, type);
7571 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7572 namesv = PAD_SVl(targ);
7573 SvUPGRADE(namesv, SVt_PV);
7575 sv_setpvs(namesv, "$");
7576 sv_catpvn(namesv, name, len);
7579 kid->op_sibling = 0;
7580 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7581 kid->op_targ = targ;
7582 kid->op_private |= priv;
7584 kid->op_sibling = sibl;
7590 op_lvalue(scalar(kid), type);
7594 tokid = &kid->op_sibling;
7595 kid = kid->op_sibling;
7598 if (kid && kid->op_type != OP_STUB)
7599 return too_many_arguments(o,OP_DESC(o));
7600 o->op_private |= numargs;
7602 /* FIXME - should the numargs move as for the PERL_MAD case? */
7603 o->op_private |= numargs;
7605 return too_many_arguments(o,OP_DESC(o));
7609 else if (PL_opargs[type] & OA_DEFGV) {
7611 OP *newop = newUNOP(type, 0, newDEFSVOP());
7612 op_getmad(o,newop,'O');
7615 /* Ordering of these two is important to keep f_map.t passing. */
7617 return newUNOP(type, 0, newDEFSVOP());
7622 while (oa & OA_OPTIONAL)
7624 if (oa && oa != OA_LIST)
7625 return too_few_arguments(o,OP_DESC(o));
7631 Perl_ck_glob(pTHX_ OP *o)
7636 PERL_ARGS_ASSERT_CK_GLOB;
7639 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7640 op_append_elem(OP_GLOB, o, newDEFSVOP());
7642 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7643 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7645 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7648 #if !defined(PERL_EXTERNAL_GLOB)
7649 /* XXX this can be tightened up and made more failsafe. */
7650 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7653 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7654 newSVpvs("File::Glob"), NULL, NULL, NULL);
7655 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7656 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7657 GvCV(gv) = GvCV(glob_gv);
7658 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7659 GvIMPORTED_CV_on(gv);
7663 #endif /* PERL_EXTERNAL_GLOB */
7665 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7666 op_append_elem(OP_GLOB, o,
7667 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7668 o->op_type = OP_LIST;
7669 o->op_ppaddr = PL_ppaddr[OP_LIST];
7670 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7671 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7672 cLISTOPo->op_first->op_targ = 0;
7673 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7674 op_append_elem(OP_LIST, o,
7675 scalar(newUNOP(OP_RV2CV, 0,
7676 newGVOP(OP_GV, 0, gv)))));
7677 o = newUNOP(OP_NULL, 0, ck_subr(o));
7678 o->op_targ = OP_GLOB; /* hint at what it used to be */
7681 gv = newGVgen("main");
7683 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7689 Perl_ck_grep(pTHX_ OP *o)
7694 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7697 PERL_ARGS_ASSERT_CK_GREP;
7699 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7700 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7702 if (o->op_flags & OPf_STACKED) {
7705 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7706 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7707 return no_fh_allowed(o);
7708 for (k = kid; k; k = k->op_next) {
7711 NewOp(1101, gwop, 1, LOGOP);
7712 kid->op_next = (OP*)gwop;
7713 o->op_flags &= ~OPf_STACKED;
7715 kid = cLISTOPo->op_first->op_sibling;
7716 if (type == OP_MAPWHILE)
7721 if (PL_parser && PL_parser->error_count)
7723 kid = cLISTOPo->op_first->op_sibling;
7724 if (kid->op_type != OP_NULL)
7725 Perl_croak(aTHX_ "panic: ck_grep");
7726 kid = kUNOP->op_first;
7729 NewOp(1101, gwop, 1, LOGOP);
7730 gwop->op_type = type;
7731 gwop->op_ppaddr = PL_ppaddr[type];
7732 gwop->op_first = listkids(o);
7733 gwop->op_flags |= OPf_KIDS;
7734 gwop->op_other = LINKLIST(kid);
7735 kid->op_next = (OP*)gwop;
7736 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7737 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7738 o->op_private = gwop->op_private = 0;
7739 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7742 o->op_private = gwop->op_private = OPpGREP_LEX;
7743 gwop->op_targ = o->op_targ = offset;
7746 kid = cLISTOPo->op_first->op_sibling;
7747 if (!kid || !kid->op_sibling)
7748 return too_few_arguments(o,OP_DESC(o));
7749 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7750 op_lvalue(kid, OP_GREPSTART);
7756 Perl_ck_index(pTHX_ OP *o)
7758 PERL_ARGS_ASSERT_CK_INDEX;
7760 if (o->op_flags & OPf_KIDS) {
7761 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7763 kid = kid->op_sibling; /* get past "big" */
7764 if (kid && kid->op_type == OP_CONST)
7765 fbm_compile(((SVOP*)kid)->op_sv, 0);
7771 Perl_ck_lfun(pTHX_ OP *o)
7773 const OPCODE type = o->op_type;
7775 PERL_ARGS_ASSERT_CK_LFUN;
7777 return modkids(ck_fun(o), type);
7781 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7783 PERL_ARGS_ASSERT_CK_DEFINED;
7785 if ((o->op_flags & OPf_KIDS)) {
7786 switch (cUNOPo->op_first->op_type) {
7788 /* This is needed for
7789 if (defined %stash::)
7790 to work. Do not break Tk.
7792 break; /* Globals via GV can be undef */
7794 case OP_AASSIGN: /* Is this a good idea? */
7795 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7796 "defined(@array) is deprecated");
7797 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7798 "\t(Maybe you should just omit the defined()?)\n");
7802 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7803 "defined(%%hash) is deprecated");
7804 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7805 "\t(Maybe you should just omit the defined()?)\n");
7816 Perl_ck_readline(pTHX_ OP *o)
7818 PERL_ARGS_ASSERT_CK_READLINE;
7820 if (!(o->op_flags & OPf_KIDS)) {
7822 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7824 op_getmad(o,newop,'O');
7834 Perl_ck_rfun(pTHX_ OP *o)
7836 const OPCODE type = o->op_type;
7838 PERL_ARGS_ASSERT_CK_RFUN;
7840 return refkids(ck_fun(o), type);
7844 Perl_ck_listiob(pTHX_ OP *o)
7848 PERL_ARGS_ASSERT_CK_LISTIOB;
7850 kid = cLISTOPo->op_first;
7853 kid = cLISTOPo->op_first;
7855 if (kid->op_type == OP_PUSHMARK)
7856 kid = kid->op_sibling;
7857 if (kid && o->op_flags & OPf_STACKED)
7858 kid = kid->op_sibling;
7859 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7860 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7861 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7862 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7863 cLISTOPo->op_first->op_sibling = kid;
7864 cLISTOPo->op_last = kid;
7865 kid = kid->op_sibling;
7870 op_append_elem(o->op_type, o, newDEFSVOP());
7876 Perl_ck_smartmatch(pTHX_ OP *o)
7879 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7880 if (0 == (o->op_flags & OPf_SPECIAL)) {
7881 OP *first = cBINOPo->op_first;
7882 OP *second = first->op_sibling;
7884 /* Implicitly take a reference to an array or hash */
7885 first->op_sibling = NULL;
7886 first = cBINOPo->op_first = ref_array_or_hash(first);
7887 second = first->op_sibling = ref_array_or_hash(second);
7889 /* Implicitly take a reference to a regular expression */
7890 if (first->op_type == OP_MATCH) {
7891 first->op_type = OP_QR;
7892 first->op_ppaddr = PL_ppaddr[OP_QR];
7894 if (second->op_type == OP_MATCH) {
7895 second->op_type = OP_QR;
7896 second->op_ppaddr = PL_ppaddr[OP_QR];
7905 Perl_ck_sassign(pTHX_ OP *o)
7908 OP * const kid = cLISTOPo->op_first;
7910 PERL_ARGS_ASSERT_CK_SASSIGN;
7912 /* has a disposable target? */
7913 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7914 && !(kid->op_flags & OPf_STACKED)
7915 /* Cannot steal the second time! */
7916 && !(kid->op_private & OPpTARGET_MY)
7917 /* Keep the full thing for madskills */
7921 OP * const kkid = kid->op_sibling;
7923 /* Can just relocate the target. */
7924 if (kkid && kkid->op_type == OP_PADSV
7925 && !(kkid->op_private & OPpLVAL_INTRO))
7927 kid->op_targ = kkid->op_targ;
7929 /* Now we do not need PADSV and SASSIGN. */
7930 kid->op_sibling = o->op_sibling; /* NULL */
7931 cLISTOPo->op_first = NULL;
7934 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7938 if (kid->op_sibling) {
7939 OP *kkid = kid->op_sibling;
7940 if (kkid->op_type == OP_PADSV
7941 && (kkid->op_private & OPpLVAL_INTRO)
7942 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7943 const PADOFFSET target = kkid->op_targ;
7944 OP *const other = newOP(OP_PADSV,
7946 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7947 OP *const first = newOP(OP_NULL, 0);
7948 OP *const nullop = newCONDOP(0, first, o, other);
7949 OP *const condop = first->op_next;
7950 /* hijacking PADSTALE for uninitialized state variables */
7951 SvPADSTALE_on(PAD_SVl(target));
7953 condop->op_type = OP_ONCE;
7954 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7955 condop->op_targ = target;
7956 other->op_targ = target;
7958 /* Because we change the type of the op here, we will skip the
7959 assinment binop->op_last = binop->op_first->op_sibling; at the
7960 end of Perl_newBINOP(). So need to do it here. */
7961 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7970 Perl_ck_match(pTHX_ OP *o)
7974 PERL_ARGS_ASSERT_CK_MATCH;
7976 if (o->op_type != OP_QR && PL_compcv) {
7977 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7978 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7979 o->op_targ = offset;
7980 o->op_private |= OPpTARGET_MY;
7983 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7984 o->op_private |= OPpRUNTIME;
7989 Perl_ck_method(pTHX_ OP *o)
7991 OP * const kid = cUNOPo->op_first;
7993 PERL_ARGS_ASSERT_CK_METHOD;
7995 if (kid->op_type == OP_CONST) {
7996 SV* sv = kSVOP->op_sv;
7997 const char * const method = SvPVX_const(sv);
7998 if (!(strchr(method, ':') || strchr(method, '\''))) {
8000 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8001 sv = newSVpvn_share(method, SvCUR(sv), 0);
8004 kSVOP->op_sv = NULL;
8006 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8008 op_getmad(o,cmop,'O');
8019 Perl_ck_null(pTHX_ OP *o)
8021 PERL_ARGS_ASSERT_CK_NULL;
8022 PERL_UNUSED_CONTEXT;
8027 Perl_ck_open(pTHX_ OP *o)
8030 HV * const table = GvHV(PL_hintgv);
8032 PERL_ARGS_ASSERT_CK_OPEN;
8035 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8038 const char *d = SvPV_const(*svp, len);
8039 const I32 mode = mode_from_discipline(d, len);
8040 if (mode & O_BINARY)
8041 o->op_private |= OPpOPEN_IN_RAW;
8042 else if (mode & O_TEXT)
8043 o->op_private |= OPpOPEN_IN_CRLF;
8046 svp = hv_fetchs(table, "open_OUT", FALSE);
8049 const char *d = SvPV_const(*svp, len);
8050 const I32 mode = mode_from_discipline(d, len);
8051 if (mode & O_BINARY)
8052 o->op_private |= OPpOPEN_OUT_RAW;
8053 else if (mode & O_TEXT)
8054 o->op_private |= OPpOPEN_OUT_CRLF;
8057 if (o->op_type == OP_BACKTICK) {
8058 if (!(o->op_flags & OPf_KIDS)) {
8059 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8061 op_getmad(o,newop,'O');
8070 /* In case of three-arg dup open remove strictness
8071 * from the last arg if it is a bareword. */
8072 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8073 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8077 if ((last->op_type == OP_CONST) && /* The bareword. */
8078 (last->op_private & OPpCONST_BARE) &&
8079 (last->op_private & OPpCONST_STRICT) &&
8080 (oa = first->op_sibling) && /* The fh. */
8081 (oa = oa->op_sibling) && /* The mode. */
8082 (oa->op_type == OP_CONST) &&
8083 SvPOK(((SVOP*)oa)->op_sv) &&
8084 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8085 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8086 (last == oa->op_sibling)) /* The bareword. */
8087 last->op_private &= ~OPpCONST_STRICT;
8093 Perl_ck_repeat(pTHX_ OP *o)
8095 PERL_ARGS_ASSERT_CK_REPEAT;
8097 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8098 o->op_private |= OPpREPEAT_DOLIST;
8099 cBINOPo->op_first = force_list(cBINOPo->op_first);
8107 Perl_ck_require(pTHX_ OP *o)
8112 PERL_ARGS_ASSERT_CK_REQUIRE;
8114 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8115 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8117 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8118 SV * const sv = kid->op_sv;
8119 U32 was_readonly = SvREADONLY(sv);
8126 sv_force_normal_flags(sv, 0);
8127 assert(!SvREADONLY(sv));
8137 for (; s < end; s++) {
8138 if (*s == ':' && s[1] == ':') {
8140 Move(s+2, s+1, end - s - 1, char);
8145 sv_catpvs(sv, ".pm");
8146 SvFLAGS(sv) |= was_readonly;
8150 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8151 /* handle override, if any */
8152 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8153 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8154 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8155 gv = gvp ? *gvp : NULL;
8159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8160 OP * const kid = cUNOPo->op_first;
8163 cUNOPo->op_first = 0;
8167 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8168 op_append_elem(OP_LIST, kid,
8169 scalar(newUNOP(OP_RV2CV, 0,
8172 op_getmad(o,newop,'O');
8176 return scalar(ck_fun(o));
8180 Perl_ck_return(pTHX_ OP *o)
8185 PERL_ARGS_ASSERT_CK_RETURN;
8187 kid = cLISTOPo->op_first->op_sibling;
8188 if (CvLVALUE(PL_compcv)) {
8189 for (; kid; kid = kid->op_sibling)
8190 op_lvalue(kid, OP_LEAVESUBLV);
8192 for (; kid; kid = kid->op_sibling)
8193 if ((kid->op_type == OP_NULL)
8194 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8195 /* This is a do block */
8196 OP *op = kUNOP->op_first;
8197 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8198 op = cUNOPx(op)->op_first;
8199 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8200 /* Force the use of the caller's context */
8201 op->op_flags |= OPf_SPECIAL;
8210 Perl_ck_select(pTHX_ OP *o)
8215 PERL_ARGS_ASSERT_CK_SELECT;
8217 if (o->op_flags & OPf_KIDS) {
8218 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8219 if (kid && kid->op_sibling) {
8220 o->op_type = OP_SSELECT;
8221 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8223 return fold_constants(o);
8227 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8228 if (kid && kid->op_type == OP_RV2GV)
8229 kid->op_private &= ~HINT_STRICT_REFS;
8234 Perl_ck_shift(pTHX_ OP *o)
8237 const I32 type = o->op_type;
8239 PERL_ARGS_ASSERT_CK_SHIFT;
8241 if (!(o->op_flags & OPf_KIDS)) {
8244 if (!CvUNIQUE(PL_compcv)) {
8245 o->op_flags |= OPf_SPECIAL;
8249 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8252 OP * const oldo = o;
8253 o = newUNOP(type, 0, scalar(argop));
8254 op_getmad(oldo,o,'O');
8259 return newUNOP(type, 0, scalar(argop));
8262 return scalar(modkids(ck_push(o), type));
8266 Perl_ck_sort(pTHX_ OP *o)
8271 PERL_ARGS_ASSERT_CK_SORT;
8273 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8274 HV * const hinthv = GvHV(PL_hintgv);
8276 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8278 const I32 sorthints = (I32)SvIV(*svp);
8279 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8280 o->op_private |= OPpSORT_QSORT;
8281 if ((sorthints & HINT_SORT_STABLE) != 0)
8282 o->op_private |= OPpSORT_STABLE;
8287 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8289 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8290 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8292 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8294 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8296 if (kid->op_type == OP_SCOPE) {
8300 else if (kid->op_type == OP_LEAVE) {
8301 if (o->op_type == OP_SORT) {
8302 op_null(kid); /* wipe out leave */
8305 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8306 if (k->op_next == kid)
8308 /* don't descend into loops */
8309 else if (k->op_type == OP_ENTERLOOP
8310 || k->op_type == OP_ENTERITER)
8312 k = cLOOPx(k)->op_lastop;
8317 kid->op_next = 0; /* just disconnect the leave */
8318 k = kLISTOP->op_first;
8323 if (o->op_type == OP_SORT) {
8324 /* provide scalar context for comparison function/block */
8330 o->op_flags |= OPf_SPECIAL;
8332 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8335 firstkid = firstkid->op_sibling;
8338 /* provide list context for arguments */
8339 if (o->op_type == OP_SORT)
8346 S_simplify_sort(pTHX_ OP *o)
8349 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8355 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8357 if (!(o->op_flags & OPf_STACKED))
8359 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8360 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8361 kid = kUNOP->op_first; /* get past null */
8362 if (kid->op_type != OP_SCOPE)
8364 kid = kLISTOP->op_last; /* get past scope */
8365 switch(kid->op_type) {
8373 k = kid; /* remember this node*/
8374 if (kBINOP->op_first->op_type != OP_RV2SV)
8376 kid = kBINOP->op_first; /* get past cmp */
8377 if (kUNOP->op_first->op_type != OP_GV)
8379 kid = kUNOP->op_first; /* get past rv2sv */
8381 if (GvSTASH(gv) != PL_curstash)
8383 gvname = GvNAME(gv);
8384 if (*gvname == 'a' && gvname[1] == '\0')
8386 else if (*gvname == 'b' && gvname[1] == '\0')
8391 kid = k; /* back to cmp */
8392 if (kBINOP->op_last->op_type != OP_RV2SV)
8394 kid = kBINOP->op_last; /* down to 2nd arg */
8395 if (kUNOP->op_first->op_type != OP_GV)
8397 kid = kUNOP->op_first; /* get past rv2sv */
8399 if (GvSTASH(gv) != PL_curstash)
8401 gvname = GvNAME(gv);
8403 ? !(*gvname == 'a' && gvname[1] == '\0')
8404 : !(*gvname == 'b' && gvname[1] == '\0'))
8406 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8408 o->op_private |= OPpSORT_DESCEND;
8409 if (k->op_type == OP_NCMP)
8410 o->op_private |= OPpSORT_NUMERIC;
8411 if (k->op_type == OP_I_NCMP)
8412 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8413 kid = cLISTOPo->op_first->op_sibling;
8414 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8416 op_getmad(kid,o,'S'); /* then delete it */
8418 op_free(kid); /* then delete it */
8423 Perl_ck_split(pTHX_ OP *o)
8428 PERL_ARGS_ASSERT_CK_SPLIT;
8430 if (o->op_flags & OPf_STACKED)
8431 return no_fh_allowed(o);
8433 kid = cLISTOPo->op_first;
8434 if (kid->op_type != OP_NULL)
8435 Perl_croak(aTHX_ "panic: ck_split");
8436 kid = kid->op_sibling;
8437 op_free(cLISTOPo->op_first);
8438 cLISTOPo->op_first = kid;
8440 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8441 cLISTOPo->op_last = kid; /* There was only one element previously */
8444 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8445 OP * const sibl = kid->op_sibling;
8446 kid->op_sibling = 0;
8447 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8448 if (cLISTOPo->op_first == cLISTOPo->op_last)
8449 cLISTOPo->op_last = kid;
8450 cLISTOPo->op_first = kid;
8451 kid->op_sibling = sibl;
8454 kid->op_type = OP_PUSHRE;
8455 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8457 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8458 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8459 "Use of /g modifier is meaningless in split");
8462 if (!kid->op_sibling)
8463 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8465 kid = kid->op_sibling;
8468 if (!kid->op_sibling)
8469 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8470 assert(kid->op_sibling);
8472 kid = kid->op_sibling;
8475 if (kid->op_sibling)
8476 return too_many_arguments(o,OP_DESC(o));
8482 Perl_ck_join(pTHX_ OP *o)
8484 const OP * const kid = cLISTOPo->op_first->op_sibling;
8486 PERL_ARGS_ASSERT_CK_JOIN;
8488 if (kid && kid->op_type == OP_MATCH) {
8489 if (ckWARN(WARN_SYNTAX)) {
8490 const REGEXP *re = PM_GETRE(kPMOP);
8491 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8492 const STRLEN len = re ? RX_PRELEN(re) : 6;
8493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8494 "/%.*s/ should probably be written as \"%.*s\"",
8495 (int)len, pmstr, (int)len, pmstr);
8502 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8504 Examines an op, which is expected to identify a subroutine at runtime,
8505 and attempts to determine at compile time which subroutine it identifies.
8506 This is normally used during Perl compilation to determine whether
8507 a prototype can be applied to a function call. I<cvop> is the op
8508 being considered, normally an C<rv2cv> op. A pointer to the identified
8509 subroutine is returned, if it could be determined statically, and a null
8510 pointer is returned if it was not possible to determine statically.
8512 Currently, the subroutine can be identified statically if the RV that the
8513 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8514 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8515 suitable if the constant value must be an RV pointing to a CV. Details of
8516 this process may change in future versions of Perl. If the C<rv2cv> op
8517 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8518 the subroutine statically: this flag is used to suppress compile-time
8519 magic on a subroutine call, forcing it to use default runtime behaviour.
8521 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8522 of a GV reference is modified. If a GV was examined and its CV slot was
8523 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8524 If the op is not optimised away, and the CV slot is later populated with
8525 a subroutine having a prototype, that flag eventually triggers the warning
8526 "called too early to check prototype".
8528 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8529 of returning a pointer to the subroutine it returns a pointer to the
8530 GV giving the most appropriate name for the subroutine in this context.
8531 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8532 (C<CvANON>) subroutine that is referenced through a GV it will be the
8533 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8534 A null pointer is returned as usual if there is no statically-determinable
8541 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8546 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8547 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8548 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8549 if (cvop->op_type != OP_RV2CV)
8551 if (cvop->op_private & OPpENTERSUB_AMPER)
8553 if (!(cvop->op_flags & OPf_KIDS))
8555 rvop = cUNOPx(cvop)->op_first;
8556 switch (rvop->op_type) {
8558 gv = cGVOPx_gv(rvop);
8561 if (flags & RV2CVOPCV_MARK_EARLY)
8562 rvop->op_private |= OPpEARLY_CV;
8567 SV *rv = cSVOPx_sv(rvop);
8577 if (SvTYPE((SV*)cv) != SVt_PVCV)
8579 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8580 if (!CvANON(cv) || !gv)
8589 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8591 Performs the default fixup of the arguments part of an C<entersub>
8592 op tree. This consists of applying list context to each of the
8593 argument ops. This is the standard treatment used on a call marked
8594 with C<&>, or a method call, or a call through a subroutine reference,
8595 or any other call where the callee can't be identified at compile time,
8596 or a call where the callee has no prototype.
8602 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8605 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8606 aop = cUNOPx(entersubop)->op_first;
8607 if (!aop->op_sibling)
8608 aop = cUNOPx(aop)->op_first;
8609 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8610 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8612 op_lvalue(aop, OP_ENTERSUB);
8619 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8621 Performs the fixup of the arguments part of an C<entersub> op tree
8622 based on a subroutine prototype. This makes various modifications to
8623 the argument ops, from applying context up to inserting C<refgen> ops,
8624 and checking the number and syntactic types of arguments, as directed by
8625 the prototype. This is the standard treatment used on a subroutine call,
8626 not marked with C<&>, where the callee can be identified at compile time
8627 and has a prototype.
8629 I<protosv> supplies the subroutine prototype to be applied to the call.
8630 It may be a normal defined scalar, of which the string value will be used.
8631 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8632 that has been cast to C<SV*>) which has a prototype. The prototype
8633 supplied, in whichever form, does not need to match the actual callee
8634 referenced by the op tree.
8636 If the argument ops disagree with the prototype, for example by having
8637 an unacceptable number of arguments, a valid op tree is returned anyway.
8638 The error is reflected in the parser state, normally resulting in a single
8639 exception at the top level of parsing which covers all the compilation
8640 errors that occurred. In the error message, the callee is referred to
8641 by the name defined by the I<namegv> parameter.
8647 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8650 const char *proto, *proto_end;
8651 OP *aop, *prev, *cvop;
8654 I32 contextclass = 0;
8655 const char *e = NULL;
8656 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8657 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8658 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8659 proto = SvPV(protosv, proto_len);
8660 proto_end = proto + proto_len;
8661 aop = cUNOPx(entersubop)->op_first;
8662 if (!aop->op_sibling)
8663 aop = cUNOPx(aop)->op_first;
8665 aop = aop->op_sibling;
8666 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8667 while (aop != cvop) {
8669 if (PL_madskills && aop->op_type == OP_STUB) {
8670 aop = aop->op_sibling;
8673 if (PL_madskills && aop->op_type == OP_NULL)
8674 o3 = ((UNOP*)aop)->op_first;
8678 if (proto >= proto_end)
8679 return too_many_arguments(entersubop, gv_ename(namegv));
8687 /* _ must be at the end */
8688 if (proto[1] && proto[1] != ';')
8703 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8705 arg == 1 ? "block or sub {}" : "sub {}",
8706 gv_ename(namegv), o3);
8709 /* '*' allows any scalar type, including bareword */
8712 if (o3->op_type == OP_RV2GV)
8713 goto wrapref; /* autoconvert GLOB -> GLOBref */
8714 else if (o3->op_type == OP_CONST)
8715 o3->op_private &= ~OPpCONST_STRICT;
8716 else if (o3->op_type == OP_ENTERSUB) {
8717 /* accidental subroutine, revert to bareword */
8718 OP *gvop = ((UNOP*)o3)->op_first;
8719 if (gvop && gvop->op_type == OP_NULL) {
8720 gvop = ((UNOP*)gvop)->op_first;
8722 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8725 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8726 (gvop = ((UNOP*)gvop)->op_first) &&
8727 gvop->op_type == OP_GV)
8729 GV * const gv = cGVOPx_gv(gvop);
8730 OP * const sibling = aop->op_sibling;
8731 SV * const n = newSVpvs("");
8733 OP * const oldaop = aop;
8737 gv_fullname4(n, gv, "", FALSE);
8738 aop = newSVOP(OP_CONST, 0, n);
8739 op_getmad(oldaop,aop,'O');
8740 prev->op_sibling = aop;
8741 aop->op_sibling = sibling;
8751 if (o3->op_type == OP_RV2AV ||
8752 o3->op_type == OP_PADAV ||
8753 o3->op_type == OP_RV2HV ||
8754 o3->op_type == OP_PADHV
8769 if (contextclass++ == 0) {
8770 e = strchr(proto, ']');
8771 if (!e || e == proto)
8780 const char *p = proto;
8781 const char *const end = proto;
8783 while (*--p != '[') {}
8784 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8786 gv_ename(namegv), o3);
8791 if (o3->op_type == OP_RV2GV)
8794 bad_type(arg, "symbol", gv_ename(namegv), o3);
8797 if (o3->op_type == OP_ENTERSUB)
8800 bad_type(arg, "subroutine entry", gv_ename(namegv),
8804 if (o3->op_type == OP_RV2SV ||
8805 o3->op_type == OP_PADSV ||
8806 o3->op_type == OP_HELEM ||
8807 o3->op_type == OP_AELEM)
8810 bad_type(arg, "scalar", gv_ename(namegv), o3);
8813 if (o3->op_type == OP_RV2AV ||
8814 o3->op_type == OP_PADAV)
8817 bad_type(arg, "array", gv_ename(namegv), o3);
8820 if (o3->op_type == OP_RV2HV ||
8821 o3->op_type == OP_PADHV)
8824 bad_type(arg, "hash", gv_ename(namegv), o3);
8828 OP* const kid = aop;
8829 OP* const sib = kid->op_sibling;
8830 kid->op_sibling = 0;
8831 aop = newUNOP(OP_REFGEN, 0, kid);
8832 aop->op_sibling = sib;
8833 prev->op_sibling = aop;
8835 if (contextclass && e) {
8850 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8851 gv_ename(namegv), SVfARG(protosv));
8854 op_lvalue(aop, OP_ENTERSUB);
8856 aop = aop->op_sibling;
8858 if (aop == cvop && *proto == '_') {
8859 /* generate an access to $_ */
8861 aop->op_sibling = prev->op_sibling;
8862 prev->op_sibling = aop; /* instead of cvop */
8864 if (!optional && proto_end > proto &&
8865 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8866 return too_few_arguments(entersubop, gv_ename(namegv));
8871 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8873 Performs the fixup of the arguments part of an C<entersub> op tree either
8874 based on a subroutine prototype or using default list-context processing.
8875 This is the standard treatment used on a subroutine call, not marked
8876 with C<&>, where the callee can be identified at compile time.
8878 I<protosv> supplies the subroutine prototype to be applied to the call,
8879 or indicates that there is no prototype. It may be a normal scalar,
8880 in which case if it is defined then the string value will be used
8881 as a prototype, and if it is undefined then there is no prototype.
8882 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8883 that has been cast to C<SV*>), of which the prototype will be used if it
8884 has one. The prototype (or lack thereof) supplied, in whichever form,
8885 does not need to match the actual callee referenced by the op tree.
8887 If the argument ops disagree with the prototype, for example by having
8888 an unacceptable number of arguments, a valid op tree is returned anyway.
8889 The error is reflected in the parser state, normally resulting in a single
8890 exception at the top level of parsing which covers all the compilation
8891 errors that occurred. In the error message, the callee is referred to
8892 by the name defined by the I<namegv> parameter.
8898 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8899 GV *namegv, SV *protosv)
8901 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8902 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8903 return ck_entersub_args_proto(entersubop, namegv, protosv);
8905 return ck_entersub_args_list(entersubop);
8909 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8911 Retrieves the function that will be used to fix up a call to I<cv>.
8912 Specifically, the function is applied to an C<entersub> op tree for a
8913 subroutine call, not marked with C<&>, where the callee can be identified
8914 at compile time as I<cv>.
8916 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8917 argument for it is returned in I<*ckobj_p>. The function is intended
8918 to be called in this manner:
8920 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8922 In this call, I<entersubop> is a pointer to the C<entersub> op,
8923 which may be replaced by the check function, and I<namegv> is a GV
8924 supplying the name that should be used by the check function to refer
8925 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8926 It is permitted to apply the check function in non-standard situations,
8927 such as to a call to a different subroutine or to a method call.
8929 By default, the function is
8930 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8931 and the SV parameter is I<cv> itself. This implements standard
8932 prototype processing. It can be changed, for a particular subroutine,
8933 by L</cv_set_call_checker>.
8939 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8942 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8943 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8945 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8946 *ckobj_p = callmg->mg_obj;
8948 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8954 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8956 Sets the function that will be used to fix up a call to I<cv>.
8957 Specifically, the function is applied to an C<entersub> op tree for a
8958 subroutine call, not marked with C<&>, where the callee can be identified
8959 at compile time as I<cv>.
8961 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8962 for it is supplied in I<ckobj>. The function is intended to be called
8965 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8967 In this call, I<entersubop> is a pointer to the C<entersub> op,
8968 which may be replaced by the check function, and I<namegv> is a GV
8969 supplying the name that should be used by the check function to refer
8970 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8971 It is permitted to apply the check function in non-standard situations,
8972 such as to a call to a different subroutine or to a method call.
8974 The current setting for a particular CV can be retrieved by
8975 L</cv_get_call_checker>.
8981 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8983 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8984 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8985 if (SvMAGICAL((SV*)cv))
8986 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8989 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8990 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8991 if (callmg->mg_flags & MGf_REFCOUNTED) {
8992 SvREFCNT_dec(callmg->mg_obj);
8993 callmg->mg_flags &= ~MGf_REFCOUNTED;
8995 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8996 callmg->mg_obj = ckobj;
8997 if (ckobj != (SV*)cv) {
8998 SvREFCNT_inc_simple_void_NN(ckobj);
8999 callmg->mg_flags |= MGf_REFCOUNTED;
9005 Perl_ck_subr(pTHX_ OP *o)
9011 PERL_ARGS_ASSERT_CK_SUBR;
9013 aop = cUNOPx(o)->op_first;
9014 if (!aop->op_sibling)
9015 aop = cUNOPx(aop)->op_first;
9016 aop = aop->op_sibling;
9017 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9018 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9019 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9021 o->op_private |= OPpENTERSUB_HASTARG;
9022 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9023 if (PERLDB_SUB && PL_curstash != PL_debstash)
9024 o->op_private |= OPpENTERSUB_DB;
9025 if (cvop->op_type == OP_RV2CV) {
9026 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9028 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9029 if (aop->op_type == OP_CONST)
9030 aop->op_private &= ~OPpCONST_STRICT;
9031 else if (aop->op_type == OP_LIST) {
9032 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9033 if (sib && sib->op_type == OP_CONST)
9034 sib->op_private &= ~OPpCONST_STRICT;
9039 return ck_entersub_args_list(o);
9041 Perl_call_checker ckfun;
9043 cv_get_call_checker(cv, &ckfun, &ckobj);
9044 return ckfun(aTHX_ o, namegv, ckobj);
9049 Perl_ck_svconst(pTHX_ OP *o)
9051 PERL_ARGS_ASSERT_CK_SVCONST;
9052 PERL_UNUSED_CONTEXT;
9053 SvREADONLY_on(cSVOPo->op_sv);
9058 Perl_ck_chdir(pTHX_ OP *o)
9060 PERL_ARGS_ASSERT_CK_CHDIR;
9061 if (o->op_flags & OPf_KIDS) {
9062 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9064 if (kid && kid->op_type == OP_CONST &&
9065 (kid->op_private & OPpCONST_BARE))
9067 o->op_flags |= OPf_SPECIAL;
9068 kid->op_private &= ~OPpCONST_STRICT;
9075 Perl_ck_trunc(pTHX_ OP *o)
9077 PERL_ARGS_ASSERT_CK_TRUNC;
9079 if (o->op_flags & OPf_KIDS) {
9080 SVOP *kid = (SVOP*)cUNOPo->op_first;
9082 if (kid->op_type == OP_NULL)
9083 kid = (SVOP*)kid->op_sibling;
9084 if (kid && kid->op_type == OP_CONST &&
9085 (kid->op_private & OPpCONST_BARE))
9087 o->op_flags |= OPf_SPECIAL;
9088 kid->op_private &= ~OPpCONST_STRICT;
9095 Perl_ck_unpack(pTHX_ OP *o)
9097 OP *kid = cLISTOPo->op_first;
9099 PERL_ARGS_ASSERT_CK_UNPACK;
9101 if (kid->op_sibling) {
9102 kid = kid->op_sibling;
9103 if (!kid->op_sibling)
9104 kid->op_sibling = newDEFSVOP();
9110 Perl_ck_substr(pTHX_ OP *o)
9112 PERL_ARGS_ASSERT_CK_SUBSTR;
9115 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9116 OP *kid = cLISTOPo->op_first;
9118 if (kid->op_type == OP_NULL)
9119 kid = kid->op_sibling;
9121 kid->op_flags |= OPf_MOD;
9128 Perl_ck_push(pTHX_ OP *o)
9131 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9135 PERL_ARGS_ASSERT_CK_PUSH;
9137 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9139 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9142 /* If not array or array deref, wrap it with an array deref.
9143 * For OP_CONST, we only wrap arrayrefs */
9145 if ( ( cursor->op_type != OP_PADAV
9146 && cursor->op_type != OP_RV2AV
9147 && cursor->op_type != OP_CONST
9150 ( cursor->op_type == OP_CONST
9151 && SvROK(cSVOPx_sv(cursor))
9152 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9155 proxy = newAVREF(cursor);
9156 if ( cursor == kid ) {
9157 cLISTOPx(o)->op_first = proxy;
9160 cLISTOPx(kid)->op_sibling = proxy;
9162 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9163 cLISTOPx(cursor)->op_sibling = NULL;
9170 Perl_ck_each(pTHX_ OP *o)
9173 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9174 const unsigned orig_type = o->op_type;
9175 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9176 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9177 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9178 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9180 PERL_ARGS_ASSERT_CK_EACH;
9183 switch (kid->op_type) {
9189 CHANGE_TYPE(o, array_type);
9192 if (kid->op_private == OPpCONST_BARE)
9193 /* we let ck_fun treat as hash */
9196 CHANGE_TYPE(o, ref_type);
9199 /* if treating as a reference, defer additional checks to runtime */
9200 return o->op_type == ref_type ? o : ck_fun(o);
9203 /* caller is supposed to assign the return to the
9204 container of the rep_op var */
9206 S_opt_scalarhv(pTHX_ OP *rep_op) {
9210 PERL_ARGS_ASSERT_OPT_SCALARHV;
9212 NewOp(1101, unop, 1, UNOP);
9213 unop->op_type = (OPCODE)OP_BOOLKEYS;
9214 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9215 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9216 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9217 unop->op_first = rep_op;
9218 unop->op_next = rep_op->op_next;
9219 rep_op->op_next = (OP*)unop;
9220 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9221 unop->op_sibling = rep_op->op_sibling;
9222 rep_op->op_sibling = NULL;
9223 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9224 if (rep_op->op_type == OP_PADHV) {
9225 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9226 rep_op->op_flags |= OPf_WANT_LIST;
9231 /* Checks if o acts as an in-place operator on an array. oright points to the
9232 * beginning of the right-hand side. Returns the left-hand side of the
9233 * assignment if o acts in-place, or NULL otherwise. */
9236 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9240 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9243 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9244 || oright->op_next != o
9245 || (oright->op_private & OPpLVAL_INTRO)
9249 /* o2 follows the chain of op_nexts through the LHS of the
9250 * assign (if any) to the aassign op itself */
9252 if (!o2 || o2->op_type != OP_NULL)
9255 if (!o2 || o2->op_type != OP_PUSHMARK)
9258 if (o2 && o2->op_type == OP_GV)
9261 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9262 || (o2->op_private & OPpLVAL_INTRO)
9267 if (!o2 || o2->op_type != OP_NULL)
9270 if (!o2 || o2->op_type != OP_AASSIGN
9271 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9274 /* check that the sort is the first arg on RHS of assign */
9276 o2 = cUNOPx(o2)->op_first;
9277 if (!o2 || o2->op_type != OP_NULL)
9279 o2 = cUNOPx(o2)->op_first;
9280 if (!o2 || o2->op_type != OP_PUSHMARK)
9282 if (o2->op_sibling != o)
9285 /* check the array is the same on both sides */
9286 if (oleft->op_type == OP_RV2AV) {
9287 if (oright->op_type != OP_RV2AV
9288 || !cUNOPx(oright)->op_first
9289 || cUNOPx(oright)->op_first->op_type != OP_GV
9290 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9291 cGVOPx_gv(cUNOPx(oright)->op_first)
9295 else if (oright->op_type != OP_PADAV
9296 || oright->op_targ != oleft->op_targ
9303 /* A peephole optimizer. We visit the ops in the order they're to execute.
9304 * See the comments at the top of this file for more details about when
9305 * peep() is called */
9308 Perl_rpeep(pTHX_ register OP *o)
9311 register OP* oldop = NULL;
9313 if (!o || o->op_opt)
9317 SAVEVPTR(PL_curcop);
9318 for (; o; o = o->op_next) {
9321 /* By default, this op has now been optimised. A couple of cases below
9322 clear this again. */
9325 switch (o->op_type) {
9327 PL_curcop = ((COP*)o); /* for warnings */
9330 PL_curcop = ((COP*)o); /* for warnings */
9332 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9333 to carry two labels. For now, take the easier option, and skip
9334 this optimisation if the first NEXTSTATE has a label. */
9335 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
9336 OP *nextop = o->op_next;
9337 while (nextop && nextop->op_type == OP_NULL)
9338 nextop = nextop->op_next;
9340 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9341 COP *firstcop = (COP *)o;
9342 COP *secondcop = (COP *)nextop;
9343 /* We want the COP pointed to by o (and anything else) to
9344 become the next COP down the line. */
9347 firstcop->op_next = secondcop->op_next;
9349 /* Now steal all its pointers, and duplicate the other
9351 firstcop->cop_line = secondcop->cop_line;
9353 firstcop->cop_stashpv = secondcop->cop_stashpv;
9354 firstcop->cop_file = secondcop->cop_file;
9356 firstcop->cop_stash = secondcop->cop_stash;
9357 firstcop->cop_filegv = secondcop->cop_filegv;
9359 firstcop->cop_hints = secondcop->cop_hints;
9360 firstcop->cop_seq = secondcop->cop_seq;
9361 firstcop->cop_warnings = secondcop->cop_warnings;
9362 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9365 secondcop->cop_stashpv = NULL;
9366 secondcop->cop_file = NULL;
9368 secondcop->cop_stash = NULL;
9369 secondcop->cop_filegv = NULL;
9371 secondcop->cop_warnings = NULL;
9372 secondcop->cop_hints_hash = NULL;
9374 /* If we use op_null(), and hence leave an ex-COP, some
9375 warnings are misreported. For example, the compile-time
9376 error in 'use strict; no strict refs;' */
9377 secondcop->op_type = OP_NULL;
9378 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9384 if (cSVOPo->op_private & OPpCONST_STRICT)
9385 no_bareword_allowed(o);
9388 case OP_METHOD_NAMED:
9389 /* Relocate sv to the pad for thread safety.
9390 * Despite being a "constant", the SV is written to,
9391 * for reference counts, sv_upgrade() etc. */
9393 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9394 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9395 /* If op_sv is already a PADTMP then it is being used by
9396 * some pad, so make a copy. */
9397 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9398 SvREADONLY_on(PAD_SVl(ix));
9399 SvREFCNT_dec(cSVOPo->op_sv);
9401 else if (o->op_type != OP_METHOD_NAMED
9402 && cSVOPo->op_sv == &PL_sv_undef) {
9403 /* PL_sv_undef is hack - it's unsafe to store it in the
9404 AV that is the pad, because av_fetch treats values of
9405 PL_sv_undef as a "free" AV entry and will merrily
9406 replace them with a new SV, causing pad_alloc to think
9407 that this pad slot is free. (When, clearly, it is not)
9409 SvOK_off(PAD_SVl(ix));
9410 SvPADTMP_on(PAD_SVl(ix));
9411 SvREADONLY_on(PAD_SVl(ix));
9414 SvREFCNT_dec(PAD_SVl(ix));
9415 SvPADTMP_on(cSVOPo->op_sv);
9416 PAD_SETSV(ix, cSVOPo->op_sv);
9417 /* XXX I don't know how this isn't readonly already. */
9418 SvREADONLY_on(PAD_SVl(ix));
9420 cSVOPo->op_sv = NULL;
9427 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9428 if (o->op_next->op_private & OPpTARGET_MY) {
9429 if (o->op_flags & OPf_STACKED) /* chained concats */
9430 break; /* ignore_optimization */
9432 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9433 o->op_targ = o->op_next->op_targ;
9434 o->op_next->op_targ = 0;
9435 o->op_private |= OPpTARGET_MY;
9438 op_null(o->op_next);
9442 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9443 break; /* Scalar stub must produce undef. List stub is noop */
9447 if (o->op_targ == OP_NEXTSTATE
9448 || o->op_targ == OP_DBSTATE)
9450 PL_curcop = ((COP*)o);
9452 /* XXX: We avoid setting op_seq here to prevent later calls
9453 to rpeep() from mistakenly concluding that optimisation
9454 has already occurred. This doesn't fix the real problem,
9455 though (See 20010220.007). AMS 20010719 */
9456 /* op_seq functionality is now replaced by op_opt */
9463 if (oldop && o->op_next) {
9464 oldop->op_next = o->op_next;
9472 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9473 OP* const pop = (o->op_type == OP_PADAV) ?
9474 o->op_next : o->op_next->op_next;
9476 if (pop && pop->op_type == OP_CONST &&
9477 ((PL_op = pop->op_next)) &&
9478 pop->op_next->op_type == OP_AELEM &&
9479 !(pop->op_next->op_private &
9480 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9481 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9486 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9487 no_bareword_allowed(pop);
9488 if (o->op_type == OP_GV)
9489 op_null(o->op_next);
9490 op_null(pop->op_next);
9492 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9493 o->op_next = pop->op_next->op_next;
9494 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9495 o->op_private = (U8)i;
9496 if (o->op_type == OP_GV) {
9501 o->op_flags |= OPf_SPECIAL;
9502 o->op_type = OP_AELEMFAST;
9507 if (o->op_next->op_type == OP_RV2SV) {
9508 if (!(o->op_next->op_private & OPpDEREF)) {
9509 op_null(o->op_next);
9510 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9512 o->op_next = o->op_next->op_next;
9513 o->op_type = OP_GVSV;
9514 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9517 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9518 GV * const gv = cGVOPo_gv;
9519 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9520 /* XXX could check prototype here instead of just carping */
9521 SV * const sv = sv_newmortal();
9522 gv_efullname3(sv, gv, NULL);
9523 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9524 "%"SVf"() called too early to check prototype",
9528 else if (o->op_next->op_type == OP_READLINE
9529 && o->op_next->op_next->op_type == OP_CONCAT
9530 && (o->op_next->op_next->op_flags & OPf_STACKED))
9532 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9533 o->op_type = OP_RCATLINE;
9534 o->op_flags |= OPf_STACKED;
9535 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9536 op_null(o->op_next->op_next);
9537 op_null(o->op_next);
9547 fop = cUNOP->op_first;
9555 fop = cLOGOP->op_first;
9556 sop = fop->op_sibling;
9557 while (cLOGOP->op_other->op_type == OP_NULL)
9558 cLOGOP->op_other = cLOGOP->op_other->op_next;
9559 CALL_RPEEP(cLOGOP->op_other);
9563 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9565 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9570 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9571 while (nop && nop->op_next) {
9572 switch (nop->op_next->op_type) {
9577 lop = nop = nop->op_next;
9588 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9589 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9590 cLOGOP->op_first = opt_scalarhv(fop);
9591 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9592 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9608 while (cLOGOP->op_other->op_type == OP_NULL)
9609 cLOGOP->op_other = cLOGOP->op_other->op_next;
9610 CALL_RPEEP(cLOGOP->op_other);
9615 while (cLOOP->op_redoop->op_type == OP_NULL)
9616 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9617 CALL_RPEEP(cLOOP->op_redoop);
9618 while (cLOOP->op_nextop->op_type == OP_NULL)
9619 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9620 CALL_RPEEP(cLOOP->op_nextop);
9621 while (cLOOP->op_lastop->op_type == OP_NULL)
9622 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9623 CALL_RPEEP(cLOOP->op_lastop);
9627 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9628 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9629 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9630 cPMOP->op_pmstashstartu.op_pmreplstart
9631 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9632 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9636 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9637 && ckWARN(WARN_SYNTAX))
9639 if (o->op_next->op_sibling) {
9640 const OPCODE type = o->op_next->op_sibling->op_type;
9641 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9642 const line_t oldline = CopLINE(PL_curcop);
9643 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9644 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9645 "Statement unlikely to be reached");
9646 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9647 "\t(Maybe you meant system() when you said exec()?)\n");
9648 CopLINE_set(PL_curcop, oldline);
9659 const char *key = NULL;
9662 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9665 /* Make the CONST have a shared SV */
9666 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9667 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
9668 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
9669 key = SvPV_const(sv, keylen);
9670 lexname = newSVpvn_share(key,
9671 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9677 if ((o->op_private & (OPpLVAL_INTRO)))
9680 rop = (UNOP*)((BINOP*)o)->op_first;
9681 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9683 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9684 if (!SvPAD_TYPED(lexname))
9686 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9687 if (!fields || !GvHV(*fields))
9689 key = SvPV_const(*svp, keylen);
9690 if (!hv_fetch(GvHV(*fields), key,
9691 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9693 Perl_croak(aTHX_ "No such class field \"%s\" "
9694 "in variable %s of type %s",
9695 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9708 SVOP *first_key_op, *key_op;
9710 if ((o->op_private & (OPpLVAL_INTRO))
9711 /* I bet there's always a pushmark... */
9712 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9713 /* hmmm, no optimization if list contains only one key. */
9715 rop = (UNOP*)((LISTOP*)o)->op_last;
9716 if (rop->op_type != OP_RV2HV)
9718 if (rop->op_first->op_type == OP_PADSV)
9719 /* @$hash{qw(keys here)} */
9720 rop = (UNOP*)rop->op_first;
9722 /* @{$hash}{qw(keys here)} */
9723 if (rop->op_first->op_type == OP_SCOPE
9724 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9726 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9732 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9733 if (!SvPAD_TYPED(lexname))
9735 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9736 if (!fields || !GvHV(*fields))
9738 /* Again guessing that the pushmark can be jumped over.... */
9739 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9740 ->op_first->op_sibling;
9741 for (key_op = first_key_op; key_op;
9742 key_op = (SVOP*)key_op->op_sibling) {
9743 if (key_op->op_type != OP_CONST)
9745 svp = cSVOPx_svp(key_op);
9746 key = SvPV_const(*svp, keylen);
9747 if (!hv_fetch(GvHV(*fields), key,
9748 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9750 Perl_croak(aTHX_ "No such class field \"%s\" "
9751 "in variable %s of type %s",
9752 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9761 && ( oldop->op_type == OP_AELEM
9762 || oldop->op_type == OP_PADSV
9763 || oldop->op_type == OP_RV2SV
9764 || oldop->op_type == OP_RV2GV
9765 || oldop->op_type == OP_HELEM
9767 && (oldop->op_private & OPpDEREF)
9769 o->op_private |= OPpDEREFed;
9773 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9777 /* check that RHS of sort is a single plain array */
9778 OP *oright = cUNOPo->op_first;
9779 if (!oright || oright->op_type != OP_PUSHMARK)
9782 /* reverse sort ... can be optimised. */
9783 if (!cUNOPo->op_sibling) {
9784 /* Nothing follows us on the list. */
9785 OP * const reverse = o->op_next;
9787 if (reverse->op_type == OP_REVERSE &&
9788 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9789 OP * const pushmark = cUNOPx(reverse)->op_first;
9790 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9791 && (cUNOPx(pushmark)->op_sibling == o)) {
9792 /* reverse -> pushmark -> sort */
9793 o->op_private |= OPpSORT_REVERSE;
9795 pushmark->op_next = oright->op_next;
9801 /* make @a = sort @a act in-place */
9803 oright = cUNOPx(oright)->op_sibling;
9806 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9807 oright = cUNOPx(oright)->op_sibling;
9810 oleft = is_inplace_av(o, oright);
9814 /* transfer MODishness etc from LHS arg to RHS arg */
9815 oright->op_flags = oleft->op_flags;
9816 o->op_private |= OPpSORT_INPLACE;
9818 /* excise push->gv->rv2av->null->aassign */
9819 o2 = o->op_next->op_next;
9820 op_null(o2); /* PUSHMARK */
9822 if (o2->op_type == OP_GV) {
9823 op_null(o2); /* GV */
9826 op_null(o2); /* RV2AV or PADAV */
9827 o2 = o2->op_next->op_next;
9828 op_null(o2); /* AASSIGN */
9830 o->op_next = o2->op_next;
9836 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9839 LISTOP *enter, *exlist;
9841 /* @a = reverse @a */
9842 if ((oright = cLISTOPo->op_first)
9843 && (oright->op_type == OP_PUSHMARK)
9844 && (oright = oright->op_sibling)
9845 && (oleft = is_inplace_av(o, oright))) {
9848 /* transfer MODishness etc from LHS arg to RHS arg */
9849 oright->op_flags = oleft->op_flags;
9850 o->op_private |= OPpREVERSE_INPLACE;
9852 /* excise push->gv->rv2av->null->aassign */
9853 o2 = o->op_next->op_next;
9854 op_null(o2); /* PUSHMARK */
9856 if (o2->op_type == OP_GV) {
9857 op_null(o2); /* GV */
9860 op_null(o2); /* RV2AV or PADAV */
9861 o2 = o2->op_next->op_next;
9862 op_null(o2); /* AASSIGN */
9864 o->op_next = o2->op_next;
9868 enter = (LISTOP *) o->op_next;
9871 if (enter->op_type == OP_NULL) {
9872 enter = (LISTOP *) enter->op_next;
9876 /* for $a (...) will have OP_GV then OP_RV2GV here.
9877 for (...) just has an OP_GV. */
9878 if (enter->op_type == OP_GV) {
9879 gvop = (OP *) enter;
9880 enter = (LISTOP *) enter->op_next;
9883 if (enter->op_type == OP_RV2GV) {
9884 enter = (LISTOP *) enter->op_next;
9890 if (enter->op_type != OP_ENTERITER)
9893 iter = enter->op_next;
9894 if (!iter || iter->op_type != OP_ITER)
9897 expushmark = enter->op_first;
9898 if (!expushmark || expushmark->op_type != OP_NULL
9899 || expushmark->op_targ != OP_PUSHMARK)
9902 exlist = (LISTOP *) expushmark->op_sibling;
9903 if (!exlist || exlist->op_type != OP_NULL
9904 || exlist->op_targ != OP_LIST)
9907 if (exlist->op_last != o) {
9908 /* Mmm. Was expecting to point back to this op. */
9911 theirmark = exlist->op_first;
9912 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9915 if (theirmark->op_sibling != o) {
9916 /* There's something between the mark and the reverse, eg
9917 for (1, reverse (...))
9922 ourmark = ((LISTOP *)o)->op_first;
9923 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9926 ourlast = ((LISTOP *)o)->op_last;
9927 if (!ourlast || ourlast->op_next != o)
9930 rv2av = ourmark->op_sibling;
9931 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9932 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9933 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9934 /* We're just reversing a single array. */
9935 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9936 enter->op_flags |= OPf_STACKED;
9939 /* We don't have control over who points to theirmark, so sacrifice
9941 theirmark->op_next = ourmark->op_next;
9942 theirmark->op_flags = ourmark->op_flags;
9943 ourlast->op_next = gvop ? gvop : (OP *) enter;
9946 enter->op_private |= OPpITER_REVERSED;
9947 iter->op_private |= OPpITER_REVERSED;
9954 UNOP *refgen, *rv2cv;
9957 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9960 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9963 rv2gv = ((BINOP *)o)->op_last;
9964 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9967 refgen = (UNOP *)((BINOP *)o)->op_first;
9969 if (!refgen || refgen->op_type != OP_REFGEN)
9972 exlist = (LISTOP *)refgen->op_first;
9973 if (!exlist || exlist->op_type != OP_NULL
9974 || exlist->op_targ != OP_LIST)
9977 if (exlist->op_first->op_type != OP_PUSHMARK)
9980 rv2cv = (UNOP*)exlist->op_last;
9982 if (rv2cv->op_type != OP_RV2CV)
9985 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9986 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9987 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9989 o->op_private |= OPpASSIGN_CV_TO_GV;
9990 rv2gv->op_private |= OPpDONT_INIT_GV;
9991 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9999 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10000 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10005 Perl_cpeep_t cpeep =
10006 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10008 cpeep(aTHX_ o, oldop);
10019 Perl_peep(pTHX_ register OP *o)
10025 =head1 Custom Operators
10027 =for apidoc Ao||custom_op_xop
10028 Return the XOP structure for a given custom op. This function should be
10029 considered internal to OP_NAME and the other access macros: use them instead.
10035 Perl_custom_op_xop(pTHX_ const OP *o)
10041 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10043 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10044 assert(o->op_type == OP_CUSTOM);
10046 /* This is wrong. It assumes a function pointer can be cast to IV,
10047 * which isn't guaranteed, but this is what the old custom OP code
10048 * did. In principle it should be safer to Copy the bytes of the
10049 * pointer into a PV: since the new interface is hidden behind
10050 * functions, this can be changed later if necessary. */
10051 /* Change custom_op_xop if this ever happens */
10052 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10055 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10057 /* assume noone will have just registered a desc */
10058 if (!he && PL_custom_op_names &&
10059 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10064 /* XXX does all this need to be shared mem? */
10065 Newxz(xop, 1, XOP);
10066 pv = SvPV(HeVAL(he), l);
10067 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10068 if (PL_custom_op_descs &&
10069 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10071 pv = SvPV(HeVAL(he), l);
10072 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10074 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10078 if (!he) return &xop_null;
10080 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10085 =for apidoc Ao||custom_op_register
10086 Register a custom op. See L<perlguts/"Custom Operators">.
10092 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10096 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10098 /* see the comment in custom_op_xop */
10099 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10101 if (!PL_custom_ops)
10102 PL_custom_ops = newHV();
10104 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10105 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10110 /* Efficient sub that returns a constant scalar value. */
10112 const_sv_xsub(pTHX_ CV* cv)
10116 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10120 /* diag_listed_as: SKIPME */
10121 Perl_croak(aTHX_ "usage: %s::%s()",
10122 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10135 * c-indentation-style: bsd
10136 * c-basic-offset: 4
10137 * indent-tabs-mode: t
10140 * ex: set ts=8 sts=4 sw=4 noet: