4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
110 #if defined(PL_OP_SLAB_ALLOC)
112 #ifdef PERL_DEBUG_READONLY_OPS
113 # define PERL_SLAB_SIZE 4096
114 # include <sys/mman.h>
117 #ifndef PERL_SLAB_SIZE
118 #define PERL_SLAB_SIZE 2048
122 Perl_Slab_Alloc(pTHX_ size_t sz)
126 * To make incrementing use count easy PL_OpSlab is an I32 *
127 * To make inserting the link to slab PL_OpPtr is I32 **
128 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
129 * Add an overhead for pointer to slab and round up as a number of pointers
131 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
132 if ((PL_OpSpace -= sz) < 0) {
133 #ifdef PERL_DEBUG_READONLY_OPS
134 /* We need to allocate chunk by chunk so that we can control the VM
136 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
139 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
140 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 if(PL_OpPtr == MAP_FAILED) {
143 perror("mmap failed");
148 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
153 /* We reserve the 0'th I32 sized chunk as a use count */
154 PL_OpSlab = (I32 *) PL_OpPtr;
155 /* Reduce size by the use count word, and by the size we need.
156 * Latter is to mimic the '-=' in the if() above
158 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
159 /* Allocation pointer starts at the top.
160 Theory: because we build leaves before trunk allocating at end
161 means that at run time access is cache friendly upward
163 PL_OpPtr += PERL_SLAB_SIZE;
165 #ifdef PERL_DEBUG_READONLY_OPS
166 /* We remember this slab. */
167 /* This implementation isn't efficient, but it is simple. */
168 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
169 PL_slabs[PL_slab_count++] = PL_OpSlab;
170 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173 assert( PL_OpSpace >= 0 );
174 /* Move the allocation pointer down */
176 assert( PL_OpPtr > (I32 **) PL_OpSlab );
177 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
178 (*PL_OpSlab)++; /* Increment use count of slab */
179 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
180 assert( *PL_OpSlab > 0 );
181 return (void *)(PL_OpPtr + 1);
184 #ifdef PERL_DEBUG_READONLY_OPS
186 Perl_pending_Slabs_to_ro(pTHX) {
187 /* Turn all the allocated op slabs read only. */
188 U32 count = PL_slab_count;
189 I32 **const slabs = PL_slabs;
191 /* Reset the array of pending OP slabs, as we're about to turn this lot
192 read only. Also, do it ahead of the loop in case the warn triggers,
193 and a warn handler has an eval */
198 /* Force a new slab for any further allocation. */
202 void *const start = slabs[count];
203 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
204 if(mprotect(start, size, PROT_READ)) {
205 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
206 start, (unsigned long) size, errno);
214 S_Slab_to_rw(pTHX_ void *op)
216 I32 * const * const ptr = (I32 **) op;
217 I32 * const slab = ptr[-1];
219 PERL_ARGS_ASSERT_SLAB_TO_RW;
221 assert( ptr-1 > (I32 **) slab );
222 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
225 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
226 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
231 Perl_op_refcnt_inc(pTHX_ OP *o)
242 Perl_op_refcnt_dec(pTHX_ OP *o)
244 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
249 # define Slab_to_rw(op)
253 Perl_Slab_Free(pTHX_ void *op)
255 I32 * const * const ptr = (I32 **) op;
256 I32 * const slab = ptr[-1];
257 PERL_ARGS_ASSERT_SLAB_FREE;
258 assert( ptr-1 > (I32 **) slab );
259 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
262 if (--(*slab) == 0) {
264 # define PerlMemShared PerlMem
267 #ifdef PERL_DEBUG_READONLY_OPS
268 U32 count = PL_slab_count;
269 /* Need to remove this slab from our list of slabs */
272 if (PL_slabs[count] == slab) {
274 /* Found it. Move the entry at the end to overwrite it. */
275 DEBUG_m(PerlIO_printf(Perl_debug_log,
276 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_slabs[PL_slab_count - 1],
279 PL_slab_count, count));
280 PL_slabs[count] = PL_slabs[--PL_slab_count];
281 /* Could realloc smaller at this point, but probably not
283 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
284 perror("munmap failed");
292 PerlMemShared_free(slab);
294 if (slab == PL_OpSlab) {
301 * In the following definition, the ", (OP*)0" is just to make the compiler
302 * think the expression is of the right type: croak actually does a Siglongjmp.
304 #define CHECKOP(type,o) \
305 ((PL_op_mask && PL_op_mask[type]) \
306 ? ( op_free((OP*)o), \
307 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
309 : PL_check[type](aTHX_ (OP*)o))
311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 #define CHANGE_TYPE(o,type) \
315 o->op_type = (OPCODE)type; \
316 o->op_ppaddr = PL_ppaddr[type]; \
320 S_gv_ename(pTHX_ GV *gv)
322 SV* const tmpsv = sv_newmortal();
324 PERL_ARGS_ASSERT_GV_ENAME;
326 gv_efullname3(tmpsv, gv, NULL);
327 return SvPV_nolen_const(tmpsv);
331 S_no_fh_allowed(pTHX_ OP *o)
333 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
341 S_too_few_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
350 S_too_many_arguments(pTHX_ OP *o, const char *name)
352 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
359 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
361 PERL_ARGS_ASSERT_BAD_TYPE;
363 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
364 (int)n, name, t, OP_DESC(kid)));
368 S_no_bareword_allowed(pTHX_ const OP *o)
370 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
373 return; /* various ok barewords are hidden in extra OP_NULL */
374 qerror(Perl_mess(aTHX_
375 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
379 /* "register" allocation */
382 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
386 const bool is_our = (PL_parser->in_my == KEY_our);
388 PERL_ARGS_ASSERT_ALLOCMY;
391 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 /* Until we're using the length for real, cross check that we're being
396 assert(strlen(name) == len);
398 /* complain about "my $<special_var>" etc etc */
402 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
403 (name[1] == '_' && (*name == '$' || len > 2))))
405 /* name[2] is true if strlen(name) > 2 */
406 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
407 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
408 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
409 PL_parser->in_my == KEY_state ? "state" : "my"));
411 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
412 PL_parser->in_my == KEY_state ? "state" : "my"));
416 /* allocate a spare slot and store the name in that slot */
418 off = pad_add_name(name, len,
419 is_our ? padadd_OUR :
420 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
421 PL_parser->in_my_stash,
423 /* $_ is always in main::, even with our */
424 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
428 /* anon sub prototypes contains state vars should always be cloned,
429 * otherwise the state var would be shared between anon subs */
431 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
432 CvCLONE_on(PL_compcv);
437 /* free the body of an op without examining its contents.
438 * Always use this rather than FreeOp directly */
441 S_op_destroy(pTHX_ OP *o)
443 if (o->op_latefree) {
451 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
453 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
459 Perl_op_free(pTHX_ OP *o)
466 if (o->op_latefreed) {
473 if (o->op_private & OPpREFCOUNTED) {
484 refcnt = OpREFCNT_dec(o);
487 /* Need to find and remove any pattern match ops from the list
488 we maintain for reset(). */
489 find_and_forget_pmops(o);
499 /* Call the op_free hook if it has been set. Do it now so that it's called
500 * at the right time for refcounted ops, but still before all of the kids
504 if (o->op_flags & OPf_KIDS) {
505 register OP *kid, *nextkid;
506 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
507 nextkid = kid->op_sibling; /* Get before next freeing kid */
512 #ifdef PERL_DEBUG_READONLY_OPS
516 /* COP* is not cleared by op_clear() so that we may track line
517 * numbers etc even after null() */
518 if (type == OP_NEXTSTATE || type == OP_DBSTATE
519 || (type == OP_NULL /* the COP might have been null'ed */
520 && ((OPCODE)o->op_targ == OP_NEXTSTATE
521 || (OPCODE)o->op_targ == OP_DBSTATE))) {
526 type = (OPCODE)o->op_targ;
529 if (o->op_latefree) {
535 #ifdef DEBUG_LEAKING_SCALARS
542 Perl_op_clear(pTHX_ OP *o)
547 PERL_ARGS_ASSERT_OP_CLEAR;
550 /* if (o->op_madprop && o->op_madprop->mad_next)
552 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
553 "modification of a read only value" for a reason I can't fathom why.
554 It's the "" stringification of $_, where $_ was set to '' in a foreach
555 loop, but it defies simplification into a small test case.
556 However, commenting them out has caused ext/List/Util/t/weak.t to fail
559 mad_free(o->op_madprop);
565 switch (o->op_type) {
566 case OP_NULL: /* Was holding old type, if any. */
567 if (PL_madskills && o->op_targ != OP_NULL) {
568 o->op_type = (Optype)o->op_targ;
573 case OP_ENTEREVAL: /* Was holding hints. */
577 if (!(o->op_flags & OPf_REF)
578 || (PL_check[o->op_type] != Perl_ck_ftst))
584 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
585 /* not an OP_PADAV replacement */
586 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
591 /* It's possible during global destruction that the GV is freed
592 before the optree. Whilst the SvREFCNT_inc is happy to bump from
593 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
594 will trigger an assertion failure, because the entry to sv_clear
595 checks that the scalar is not already freed. A check of for
596 !SvIS_FREED(gv) turns out to be invalid, because during global
597 destruction the reference count can be forced down to zero
598 (with SVf_BREAK set). In which case raising to 1 and then
599 dropping to 0 triggers cleanup before it should happen. I
600 *think* that this might actually be a general, systematic,
601 weakness of the whole idea of SVf_BREAK, in that code *is*
602 allowed to raise and lower references during global destruction,
603 so any *valid* code that happens to do this during global
604 destruction might well trigger premature cleanup. */
605 bool still_valid = gv && SvREFCNT(gv);
608 SvREFCNT_inc_simple_void(gv);
610 if (cPADOPo->op_padix > 0) {
611 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
612 * may still exist on the pad */
613 pad_swipe(cPADOPo->op_padix, TRUE);
614 cPADOPo->op_padix = 0;
617 SvREFCNT_dec(cSVOPo->op_sv);
618 cSVOPo->op_sv = NULL;
621 int try_downgrade = SvREFCNT(gv) == 2;
624 gv_try_downgrade(gv);
628 case OP_METHOD_NAMED:
631 SvREFCNT_dec(cSVOPo->op_sv);
632 cSVOPo->op_sv = NULL;
635 Even if op_clear does a pad_free for the target of the op,
636 pad_free doesn't actually remove the sv that exists in the pad;
637 instead it lives on. This results in that it could be reused as
638 a target later on when the pad was reallocated.
641 pad_swipe(o->op_targ,1);
650 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
655 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
657 if (cPADOPo->op_padix > 0) {
658 pad_swipe(cPADOPo->op_padix, TRUE);
659 cPADOPo->op_padix = 0;
662 SvREFCNT_dec(cSVOPo->op_sv);
663 cSVOPo->op_sv = NULL;
667 PerlMemShared_free(cPVOPo->op_pv);
668 cPVOPo->op_pv = NULL;
672 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
676 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
677 /* No GvIN_PAD_off here, because other references may still
678 * exist on the pad */
679 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
682 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
688 forget_pmop(cPMOPo, 1);
689 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
690 /* we use the same protection as the "SAFE" version of the PM_ macros
691 * here since sv_clean_all might release some PMOPs
692 * after PL_regex_padav has been cleared
693 * and the clearing of PL_regex_padav needs to
694 * happen before sv_clean_all
697 if(PL_regex_pad) { /* We could be in destruction */
698 const IV offset = (cPMOPo)->op_pmoffset;
699 ReREFCNT_dec(PM_GETRE(cPMOPo));
700 PL_regex_pad[offset] = &PL_sv_undef;
701 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
705 ReREFCNT_dec(PM_GETRE(cPMOPo));
706 PM_SETRE(cPMOPo, NULL);
712 if (o->op_targ > 0) {
713 pad_free(o->op_targ);
719 S_cop_free(pTHX_ COP* cop)
721 PERL_ARGS_ASSERT_COP_FREE;
725 if (! specialWARN(cop->cop_warnings))
726 PerlMemShared_free(cop->cop_warnings);
727 cophh_free(CopHINTHASH_get(cop));
731 S_forget_pmop(pTHX_ PMOP *const o
737 HV * const pmstash = PmopSTASH(o);
739 PERL_ARGS_ASSERT_FORGET_PMOP;
741 if (pmstash && !SvIS_FREED(pmstash)) {
742 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
744 PMOP **const array = (PMOP**) mg->mg_ptr;
745 U32 count = mg->mg_len / sizeof(PMOP**);
750 /* Found it. Move the entry at the end to overwrite it. */
751 array[i] = array[--count];
752 mg->mg_len = count * sizeof(PMOP**);
753 /* Could realloc smaller at this point always, but probably
754 not worth it. Probably worth free()ing if we're the
757 Safefree(mg->mg_ptr);
774 S_find_and_forget_pmops(pTHX_ OP *o)
776 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
778 if (o->op_flags & OPf_KIDS) {
779 OP *kid = cUNOPo->op_first;
781 switch (kid->op_type) {
786 forget_pmop((PMOP*)kid, 0);
788 find_and_forget_pmops(kid);
789 kid = kid->op_sibling;
795 Perl_op_null(pTHX_ OP *o)
799 PERL_ARGS_ASSERT_OP_NULL;
801 if (o->op_type == OP_NULL)
805 o->op_targ = o->op_type;
806 o->op_type = OP_NULL;
807 o->op_ppaddr = PL_ppaddr[OP_NULL];
811 Perl_op_refcnt_lock(pTHX)
819 Perl_op_refcnt_unlock(pTHX)
826 /* Contextualizers */
829 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
831 Applies a syntactic context to an op tree representing an expression.
832 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
833 or C<G_VOID> to specify the context to apply. The modified op tree
840 Perl_op_contextualize(pTHX_ OP *o, I32 context)
842 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
844 case G_SCALAR: return scalar(o);
845 case G_ARRAY: return list(o);
846 case G_VOID: return scalarvoid(o);
848 Perl_croak(aTHX_ "panic: op_contextualize bad context");
854 =head1 Optree Manipulation Functions
856 =for apidoc Am|OP*|op_linklist|OP *o
857 This function is the implementation of the L</LINKLIST> macro. It should
858 not be called directly.
864 Perl_op_linklist(pTHX_ OP *o)
868 PERL_ARGS_ASSERT_OP_LINKLIST;
873 /* establish postfix order */
874 first = cUNOPo->op_first;
877 o->op_next = LINKLIST(first);
880 if (kid->op_sibling) {
881 kid->op_next = LINKLIST(kid->op_sibling);
882 kid = kid->op_sibling;
896 S_scalarkids(pTHX_ OP *o)
898 if (o && o->op_flags & OPf_KIDS) {
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 S_scalarboolean(pTHX_ OP *o)
911 PERL_ARGS_ASSERT_SCALARBOOLEAN;
913 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
914 if (ckWARN(WARN_SYNTAX)) {
915 const line_t oldline = CopLINE(PL_curcop);
917 if (PL_parser && PL_parser->copline != NOLINE)
918 CopLINE_set(PL_curcop, PL_parser->copline);
919 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
920 CopLINE_set(PL_curcop, oldline);
927 Perl_scalar(pTHX_ OP *o)
932 /* assumes no premature commitment */
933 if (!o || (PL_parser && PL_parser->error_count)
934 || (o->op_flags & OPf_WANT)
935 || o->op_type == OP_RETURN)
940 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
942 switch (o->op_type) {
944 scalar(cBINOPo->op_first);
949 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
959 if (o->op_flags & OPf_KIDS) {
960 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
966 kid = cLISTOPo->op_first;
968 kid = kid->op_sibling;
971 OP *sib = kid->op_sibling;
972 if (sib && kid->op_type != OP_LEAVEWHEN) {
973 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
983 PL_curcop = &PL_compiling;
988 kid = cLISTOPo->op_first;
991 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
998 Perl_scalarvoid(pTHX_ OP *o)
1002 const char* useless = NULL;
1006 PERL_ARGS_ASSERT_SCALARVOID;
1008 /* trailing mad null ops don't count as "there" for void processing */
1010 o->op_type != OP_NULL &&
1012 o->op_sibling->op_type == OP_NULL)
1015 for (sib = o->op_sibling;
1016 sib && sib->op_type == OP_NULL;
1017 sib = sib->op_sibling) ;
1023 if (o->op_type == OP_NEXTSTATE
1024 || o->op_type == OP_DBSTATE
1025 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1026 || o->op_targ == OP_DBSTATE)))
1027 PL_curcop = (COP*)o; /* for warning below */
1029 /* assumes no premature commitment */
1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR)
1032 || (PL_parser && PL_parser->error_count)
1033 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1038 if ((o->op_private & OPpTARGET_MY)
1039 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1041 return scalar(o); /* As if inside SASSIGN */
1044 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1046 switch (o->op_type) {
1048 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1052 if (o->op_flags & OPf_STACKED)
1056 if (o->op_private == 4)
1099 case OP_GETSOCKNAME:
1100 case OP_GETPEERNAME:
1105 case OP_GETPRIORITY:
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1130 /* Otherwise it's "Useless use of grep iterator" */
1131 useless = OP_DESC(o);
1135 kid = cLISTOPo->op_first;
1136 if (kid && kid->op_type == OP_PUSHRE
1138 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1140 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1142 useless = OP_DESC(o);
1146 kid = cUNOPo->op_first;
1147 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1148 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1151 useless = "negative pattern binding (!~)";
1155 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1156 useless = "non-destructive substitution (s///r)";
1160 useless = "non-destructive transliteration (tr///r)";
1167 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1168 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1169 useless = "a variable";
1174 if (cSVOPo->op_private & OPpCONST_STRICT)
1175 no_bareword_allowed(o);
1177 if (ckWARN(WARN_VOID)) {
1179 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1180 "a constant (%"SVf")", sv));
1181 useless = SvPV_nolen(msv);
1184 useless = "a constant (undef)";
1185 if (o->op_private & OPpCONST_ARYBASE)
1187 /* don't warn on optimised away booleans, eg
1188 * use constant Foo, 5; Foo || print; */
1189 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1191 /* the constants 0 and 1 are permitted as they are
1192 conventionally used as dummies in constructs like
1193 1 while some_condition_with_side_effects; */
1194 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1196 else if (SvPOK(sv)) {
1197 /* perl4's way of mixing documentation and code
1198 (before the invention of POD) was based on a
1199 trick to mix nroff and perl code. The trick was
1200 built upon these three nroff macros being used in
1201 void context. The pink camel has the details in
1202 the script wrapman near page 319. */
1203 const char * const maybe_macro = SvPVX_const(sv);
1204 if (strnEQ(maybe_macro, "di", 2) ||
1205 strnEQ(maybe_macro, "ds", 2) ||
1206 strnEQ(maybe_macro, "ig", 2))
1211 op_null(o); /* don't execute or even remember it */
1215 o->op_type = OP_PREINC; /* pre-increment is faster */
1216 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1220 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1221 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1225 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1230 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1231 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1236 kid = cLOGOPo->op_first;
1237 if (kid->op_type == OP_NOT
1238 && (kid->op_flags & OPf_KIDS)
1240 if (o->op_type == OP_AND) {
1242 o->op_ppaddr = PL_ppaddr[OP_OR];
1244 o->op_type = OP_AND;
1245 o->op_ppaddr = PL_ppaddr[OP_AND];
1254 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1259 if (o->op_flags & OPf_STACKED)
1266 if (!(o->op_flags & OPf_KIDS))
1277 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1287 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1292 S_listkids(pTHX_ OP *o)
1294 if (o && o->op_flags & OPf_KIDS) {
1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1303 Perl_list(pTHX_ OP *o)
1308 /* assumes no premature commitment */
1309 if (!o || (o->op_flags & OPf_WANT)
1310 || (PL_parser && PL_parser->error_count)
1311 || o->op_type == OP_RETURN)
1316 if ((o->op_private & OPpTARGET_MY)
1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1319 return o; /* As if inside SASSIGN */
1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1324 switch (o->op_type) {
1327 list(cBINOPo->op_first);
1332 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (!(o->op_flags & OPf_KIDS))
1342 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1343 list(cBINOPo->op_first);
1344 return gen_constant_list(o);
1351 kid = cLISTOPo->op_first;
1353 kid = kid->op_sibling;
1356 OP *sib = kid->op_sibling;
1357 if (sib && kid->op_type != OP_LEAVEWHEN) {
1358 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1368 PL_curcop = &PL_compiling;
1372 kid = cLISTOPo->op_first;
1379 S_scalarseq(pTHX_ OP *o)
1383 const OPCODE type = o->op_type;
1385 if (type == OP_LINESEQ || type == OP_SCOPE ||
1386 type == OP_LEAVE || type == OP_LEAVETRY)
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1390 if (kid->op_sibling) {
1394 PL_curcop = &PL_compiling;
1396 o->op_flags &= ~OPf_PARENS;
1397 if (PL_hints & HINT_BLOCK_SCOPE)
1398 o->op_flags |= OPf_PARENS;
1401 o = newOP(OP_STUB, 0);
1406 S_modkids(pTHX_ OP *o, I32 type)
1408 if (o && o->op_flags & OPf_KIDS) {
1410 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1411 op_lvalue(kid, type);
1417 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1419 Propagate lvalue ("modifiable") context to an op and its children.
1420 I<type> represents the context type, roughly based on the type of op that
1421 would do the modifying, although C<local()> is represented by OP_NULL,
1422 because it has no op type of its own (it is signalled by a flag on
1423 the lvalue op). This function detects things that can't be modified,
1424 such as C<$x+1>, and generates errors for them. It also flags things
1425 that need to behave specially in an lvalue context, such as C<$$x>
1426 which might have to vivify a reference in C<$x>.
1432 Perl_op_lvalue(pTHX_ OP *o, I32 type)
1436 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1439 if (!o || (PL_parser && PL_parser->error_count))
1442 if ((o->op_private & OPpTARGET_MY)
1443 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1448 switch (o->op_type) {
1454 if (!(o->op_private & OPpCONST_ARYBASE))
1457 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1458 CopARYBASE_set(&PL_compiling,
1459 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1463 SAVECOPARYBASE(&PL_compiling);
1464 CopARYBASE_set(&PL_compiling, 0);
1466 else if (type == OP_REFGEN)
1469 Perl_croak(aTHX_ "That use of $[ is unsupported");
1472 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1476 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1477 !(o->op_flags & OPf_STACKED)) {
1478 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1479 /* The default is to set op_private to the number of children,
1480 which for a UNOP such as RV2CV is always 1. And w're using
1481 the bit for a flag in RV2CV, so we need it clear. */
1482 o->op_private &= ~1;
1483 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1484 assert(cUNOPo->op_first->op_type == OP_NULL);
1485 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1488 else if (o->op_private & OPpENTERSUB_NOMOD)
1490 else { /* lvalue subroutine call */
1491 o->op_private |= OPpLVAL_INTRO;
1492 PL_modcount = RETURN_UNLIMITED_NUMBER;
1493 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1494 /* Backward compatibility mode: */
1495 o->op_private |= OPpENTERSUB_INARGS;
1498 else { /* Compile-time error message: */
1499 OP *kid = cUNOPo->op_first;
1503 if (kid->op_type != OP_PUSHMARK) {
1504 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1506 "panic: unexpected lvalue entersub "
1507 "args: type/targ %ld:%"UVuf,
1508 (long)kid->op_type, (UV)kid->op_targ);
1509 kid = kLISTOP->op_first;
1511 while (kid->op_sibling)
1512 kid = kid->op_sibling;
1513 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1515 if (kid->op_type == OP_METHOD_NAMED
1516 || kid->op_type == OP_METHOD)
1520 NewOp(1101, newop, 1, UNOP);
1521 newop->op_type = OP_RV2CV;
1522 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1523 newop->op_first = NULL;
1524 newop->op_next = (OP*)newop;
1525 kid->op_sibling = (OP*)newop;
1526 newop->op_private |= OPpLVAL_INTRO;
1527 newop->op_private &= ~1;
1531 if (kid->op_type != OP_RV2CV)
1533 "panic: unexpected lvalue entersub "
1534 "entry via type/targ %ld:%"UVuf,
1535 (long)kid->op_type, (UV)kid->op_targ);
1536 kid->op_private |= OPpLVAL_INTRO;
1537 break; /* Postpone until runtime */
1541 kid = kUNOP->op_first;
1542 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1543 kid = kUNOP->op_first;
1544 if (kid->op_type == OP_NULL)
1546 "Unexpected constant lvalue entersub "
1547 "entry via type/targ %ld:%"UVuf,
1548 (long)kid->op_type, (UV)kid->op_targ);
1549 if (kid->op_type != OP_GV) {
1550 /* Restore RV2CV to check lvalueness */
1552 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1553 okid->op_next = kid->op_next;
1554 kid->op_next = okid;
1557 okid->op_next = NULL;
1558 okid->op_type = OP_RV2CV;
1560 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1561 okid->op_private |= OPpLVAL_INTRO;
1562 okid->op_private &= ~1;
1566 cv = GvCV(kGVOP_gv);
1576 /* grep, foreach, subcalls, refgen */
1577 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1579 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1580 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1582 : (o->op_type == OP_ENTERSUB
1583 ? "non-lvalue subroutine call"
1585 type ? PL_op_desc[type] : "local"));
1599 case OP_RIGHT_SHIFT:
1608 if (!(o->op_flags & OPf_STACKED))
1615 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1616 op_lvalue(kid, type);
1621 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
1623 return o; /* Treat \(@foo) like ordinary list. */
1627 if (scalar_mod_type(o, type))
1629 ref(cUNOPo->op_first, o->op_type);
1633 if (type == OP_LEAVESUBLV)
1634 o->op_private |= OPpMAYBE_LVSUB;
1640 PL_modcount = RETURN_UNLIMITED_NUMBER;
1643 PL_hints |= HINT_BLOCK_SCOPE;
1644 if (type == OP_LEAVESUBLV)
1645 o->op_private |= OPpMAYBE_LVSUB;
1649 ref(cUNOPo->op_first, o->op_type);
1653 PL_hints |= HINT_BLOCK_SCOPE;
1668 PL_modcount = RETURN_UNLIMITED_NUMBER;
1669 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1670 return o; /* Treat \(@foo) like ordinary list. */
1671 if (scalar_mod_type(o, type))
1673 if (type == OP_LEAVESUBLV)
1674 o->op_private |= OPpMAYBE_LVSUB;
1678 if (!type) /* local() */
1679 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1680 PAD_COMPNAME_PV(o->op_targ));
1688 if (type != OP_SASSIGN)
1692 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1697 if (type == OP_LEAVESUBLV)
1698 o->op_private |= OPpMAYBE_LVSUB;
1700 pad_free(o->op_targ);
1701 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1702 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1703 if (o->op_flags & OPf_KIDS)
1704 op_lvalue(cBINOPo->op_first->op_sibling, type);
1709 ref(cBINOPo->op_first, o->op_type);
1710 if (type == OP_ENTERSUB &&
1711 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1712 o->op_private |= OPpLVAL_DEFER;
1713 if (type == OP_LEAVESUBLV)
1714 o->op_private |= OPpMAYBE_LVSUB;
1724 if (o->op_flags & OPf_KIDS)
1725 op_lvalue(cLISTOPo->op_last, type);
1730 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1732 else if (!(o->op_flags & OPf_KIDS))
1734 if (o->op_targ != OP_LIST) {
1735 op_lvalue(cBINOPo->op_first, type);
1741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1742 op_lvalue(kid, type);
1746 if (type != OP_LEAVESUBLV)
1748 break; /* op_lvalue()ing was handled by ck_return() */
1751 /* [20011101.069] File test operators interpret OPf_REF to mean that
1752 their argument is a filehandle; thus \stat(".") should not set
1754 if (type == OP_REFGEN &&
1755 PL_check[o->op_type] == Perl_ck_ftst)
1758 if (type != OP_LEAVESUBLV)
1759 o->op_flags |= OPf_MOD;
1761 if (type == OP_AASSIGN || type == OP_SASSIGN)
1762 o->op_flags |= OPf_SPECIAL|OPf_REF;
1763 else if (!type) { /* local() */
1766 o->op_private |= OPpLVAL_INTRO;
1767 o->op_flags &= ~OPf_SPECIAL;
1768 PL_hints |= HINT_BLOCK_SCOPE;
1773 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1774 "Useless localization of %s", OP_DESC(o));
1777 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1778 && type != OP_LEAVESUBLV)
1779 o->op_flags |= OPf_REF;
1784 S_scalar_mod_type(const OP *o, I32 type)
1786 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1790 if (o->op_type == OP_RV2GV)
1814 case OP_RIGHT_SHIFT:
1835 S_is_handle_constructor(const OP *o, I32 numargs)
1837 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1839 switch (o->op_type) {
1847 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1860 S_refkids(pTHX_ OP *o, I32 type)
1862 if (o && o->op_flags & OPf_KIDS) {
1864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1871 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1876 PERL_ARGS_ASSERT_DOREF;
1878 if (!o || (PL_parser && PL_parser->error_count))
1881 switch (o->op_type) {
1883 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1884 !(o->op_flags & OPf_STACKED)) {
1885 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1886 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1887 assert(cUNOPo->op_first->op_type == OP_NULL);
1888 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1889 o->op_flags |= OPf_SPECIAL;
1890 o->op_private &= ~1;
1895 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1896 doref(kid, type, set_op_ref);
1899 if (type == OP_DEFINED)
1900 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1901 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1904 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1905 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1906 : type == OP_RV2HV ? OPpDEREF_HV
1908 o->op_flags |= OPf_MOD;
1915 o->op_flags |= OPf_REF;
1918 if (type == OP_DEFINED)
1919 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1920 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1926 o->op_flags |= OPf_REF;
1931 if (!(o->op_flags & OPf_KIDS))
1933 doref(cBINOPo->op_first, type, set_op_ref);
1937 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1938 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1939 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1940 : type == OP_RV2HV ? OPpDEREF_HV
1942 o->op_flags |= OPf_MOD;
1952 if (!(o->op_flags & OPf_KIDS))
1954 doref(cLISTOPo->op_last, type, set_op_ref);
1964 S_dup_attrlist(pTHX_ OP *o)
1969 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1971 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1972 * where the first kid is OP_PUSHMARK and the remaining ones
1973 * are OP_CONST. We need to push the OP_CONST values.
1975 if (o->op_type == OP_CONST)
1976 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1978 else if (o->op_type == OP_NULL)
1982 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1984 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1985 if (o->op_type == OP_CONST)
1986 rop = op_append_elem(OP_LIST, rop,
1987 newSVOP(OP_CONST, o->op_flags,
1988 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1995 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2000 PERL_ARGS_ASSERT_APPLY_ATTRS;
2002 /* fake up C<use attributes $pkg,$rv,@attrs> */
2003 ENTER; /* need to protect against side-effects of 'use' */
2004 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2006 #define ATTRSMODULE "attributes"
2007 #define ATTRSMODULE_PM "attributes.pm"
2010 /* Don't force the C<use> if we don't need it. */
2011 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2012 if (svp && *svp != &PL_sv_undef)
2013 NOOP; /* already in %INC */
2015 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2016 newSVpvs(ATTRSMODULE), NULL);
2019 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2020 newSVpvs(ATTRSMODULE),
2022 op_prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0, stashsv),
2024 op_prepend_elem(OP_LIST,
2025 newSVOP(OP_CONST, 0,
2027 dup_attrlist(attrs))));
2033 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2036 OP *pack, *imop, *arg;
2039 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2044 assert(target->op_type == OP_PADSV ||
2045 target->op_type == OP_PADHV ||
2046 target->op_type == OP_PADAV);
2048 /* Ensure that attributes.pm is loaded. */
2049 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2051 /* Need package name for method call. */
2052 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2054 /* Build up the real arg-list. */
2055 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2057 arg = newOP(OP_PADSV, 0);
2058 arg->op_targ = target->op_targ;
2059 arg = op_prepend_elem(OP_LIST,
2060 newSVOP(OP_CONST, 0, stashsv),
2061 op_prepend_elem(OP_LIST,
2062 newUNOP(OP_REFGEN, 0,
2063 op_lvalue(arg, OP_REFGEN)),
2064 dup_attrlist(attrs)));
2066 /* Fake up a method call to import */
2067 meth = newSVpvs_share("import");
2068 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2069 op_append_elem(OP_LIST,
2070 op_prepend_elem(OP_LIST, pack, list(arg)),
2071 newSVOP(OP_METHOD_NAMED, 0, meth)));
2072 imop->op_private |= OPpENTERSUB_NOMOD;
2074 /* Combine the ops. */
2075 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2079 =notfor apidoc apply_attrs_string
2081 Attempts to apply a list of attributes specified by the C<attrstr> and
2082 C<len> arguments to the subroutine identified by the C<cv> argument which
2083 is expected to be associated with the package identified by the C<stashpv>
2084 argument (see L<attributes>). It gets this wrong, though, in that it
2085 does not correctly identify the boundaries of the individual attribute
2086 specifications within C<attrstr>. This is not really intended for the
2087 public API, but has to be listed here for systems such as AIX which
2088 need an explicit export list for symbols. (It's called from XS code
2089 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2090 to respect attribute syntax properly would be welcome.
2096 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2097 const char *attrstr, STRLEN len)
2101 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2104 len = strlen(attrstr);
2108 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2110 const char * const sstr = attrstr;
2111 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2112 attrs = op_append_elem(OP_LIST, attrs,
2113 newSVOP(OP_CONST, 0,
2114 newSVpvn(sstr, attrstr-sstr)));
2118 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2119 newSVpvs(ATTRSMODULE),
2120 NULL, op_prepend_elem(OP_LIST,
2121 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2122 op_prepend_elem(OP_LIST,
2123 newSVOP(OP_CONST, 0,
2124 newRV(MUTABLE_SV(cv))),
2129 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2134 PERL_ARGS_ASSERT_MY_KID;
2136 if (!o || (PL_parser && PL_parser->error_count))
2140 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2141 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2145 if (type == OP_LIST) {
2147 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2148 my_kid(kid, attrs, imopsp);
2149 } else if (type == OP_UNDEF
2155 } else if (type == OP_RV2SV || /* "our" declaration */
2157 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2159 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2161 PL_parser->in_my == KEY_our
2163 : PL_parser->in_my == KEY_state ? "state" : "my"));
2165 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2166 PL_parser->in_my = FALSE;
2167 PL_parser->in_my_stash = NULL;
2168 apply_attrs(GvSTASH(gv),
2169 (type == OP_RV2SV ? GvSV(gv) :
2170 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2171 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2174 o->op_private |= OPpOUR_INTRO;
2177 else if (type != OP_PADSV &&
2180 type != OP_PUSHMARK)
2182 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2184 PL_parser->in_my == KEY_our
2186 : PL_parser->in_my == KEY_state ? "state" : "my"));
2189 else if (attrs && type != OP_PUSHMARK) {
2192 PL_parser->in_my = FALSE;
2193 PL_parser->in_my_stash = NULL;
2195 /* check for C<my Dog $spot> when deciding package */
2196 stash = PAD_COMPNAME_TYPE(o->op_targ);
2198 stash = PL_curstash;
2199 apply_attrs_my(stash, o, attrs, imopsp);
2201 o->op_flags |= OPf_MOD;
2202 o->op_private |= OPpLVAL_INTRO;
2203 if (PL_parser->in_my == KEY_state)
2204 o->op_private |= OPpPAD_STATE;
2209 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2213 int maybe_scalar = 0;
2215 PERL_ARGS_ASSERT_MY_ATTRS;
2217 /* [perl #17376]: this appears to be premature, and results in code such as
2218 C< our(%x); > executing in list mode rather than void mode */
2220 if (o->op_flags & OPf_PARENS)
2230 o = my_kid(o, attrs, &rops);
2232 if (maybe_scalar && o->op_type == OP_PADSV) {
2233 o = scalar(op_append_list(OP_LIST, rops, o));
2234 o->op_private |= OPpLVAL_INTRO;
2237 o = op_append_list(OP_LIST, o, rops);
2239 PL_parser->in_my = FALSE;
2240 PL_parser->in_my_stash = NULL;
2245 Perl_sawparens(pTHX_ OP *o)
2247 PERL_UNUSED_CONTEXT;
2249 o->op_flags |= OPf_PARENS;
2254 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2258 const OPCODE ltype = left->op_type;
2259 const OPCODE rtype = right->op_type;
2261 PERL_ARGS_ASSERT_BIND_MATCH;
2263 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2264 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2266 const char * const desc
2268 rtype == OP_SUBST || rtype == OP_TRANS
2269 || rtype == OP_TRANSR
2271 ? (int)rtype : OP_MATCH];
2272 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2273 ? "@array" : "%hash");
2274 Perl_warner(aTHX_ packWARN(WARN_MISC),
2275 "Applying %s to %s will act on scalar(%s)",
2276 desc, sample, sample);
2279 if (rtype == OP_CONST &&
2280 cSVOPx(right)->op_private & OPpCONST_BARE &&
2281 cSVOPx(right)->op_private & OPpCONST_STRICT)
2283 no_bareword_allowed(right);
2286 /* !~ doesn't make sense with /r, so error on it for now */
2287 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2289 yyerror("Using !~ with s///r doesn't make sense");
2290 if (rtype == OP_TRANSR && type == OP_NOT)
2291 yyerror("Using !~ with tr///r doesn't make sense");
2293 ismatchop = (rtype == OP_MATCH ||
2294 rtype == OP_SUBST ||
2295 rtype == OP_TRANS || rtype == OP_TRANSR)
2296 && !(right->op_flags & OPf_SPECIAL);
2297 if (ismatchop && right->op_private & OPpTARGET_MY) {
2299 right->op_private &= ~OPpTARGET_MY;
2301 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2304 right->op_flags |= OPf_STACKED;
2305 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2306 ! (rtype == OP_TRANS &&
2307 right->op_private & OPpTRANS_IDENTICAL) &&
2308 ! (rtype == OP_SUBST &&
2309 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2310 newleft = op_lvalue(left, rtype);
2313 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2314 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2316 o = op_prepend_elem(rtype, scalar(newleft), right);
2318 return newUNOP(OP_NOT, 0, scalar(o));
2322 return bind_match(type, left,
2323 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2327 Perl_invert(pTHX_ OP *o)
2331 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2335 =for apidoc Amx|OP *|op_scope|OP *o
2337 Wraps up an op tree with some additional ops so that at runtime a dynamic
2338 scope will be created. The original ops run in the new dynamic scope,
2339 and then, provided that they exit normally, the scope will be unwound.
2340 The additional ops used to create and unwind the dynamic scope will
2341 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2342 instead if the ops are simple enough to not need the full dynamic scope
2349 Perl_op_scope(pTHX_ OP *o)
2353 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2354 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2355 o->op_type = OP_LEAVE;
2356 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2358 else if (o->op_type == OP_LINESEQ) {
2360 o->op_type = OP_SCOPE;
2361 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2362 kid = ((LISTOP*)o)->op_first;
2363 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2366 /* The following deals with things like 'do {1 for 1}' */
2367 kid = kid->op_sibling;
2369 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2374 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2380 Perl_block_start(pTHX_ int full)
2383 const int retval = PL_savestack_ix;
2385 pad_block_start(full);
2387 PL_hints &= ~HINT_BLOCK_SCOPE;
2388 SAVECOMPILEWARNINGS();
2389 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2391 CALL_BLOCK_HOOKS(bhk_start, full);
2397 Perl_block_end(pTHX_ I32 floor, OP *seq)
2400 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2401 OP* retval = scalarseq(seq);
2403 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2406 CopHINTS_set(&PL_compiling, PL_hints);
2408 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2411 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2417 =head1 Compile-time scope hooks
2419 =for apidoc Ao||blockhook_register
2421 Register a set of hooks to be called when the Perl lexical scope changes
2422 at compile time. See L<perlguts/"Compile-time scope hooks">.
2428 Perl_blockhook_register(pTHX_ BHK *hk)
2430 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2432 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2439 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2440 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2441 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2444 OP * const o = newOP(OP_PADSV, 0);
2445 o->op_targ = offset;
2451 Perl_newPROG(pTHX_ OP *o)
2455 PERL_ARGS_ASSERT_NEWPROG;
2460 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2461 ((PL_in_eval & EVAL_KEEPERR)
2462 ? OPf_SPECIAL : 0), o);
2463 /* don't use LINKLIST, since PL_eval_root might indirect through
2464 * a rather expensive function call and LINKLIST evaluates its
2465 * argument more than once */
2466 PL_eval_start = op_linklist(PL_eval_root);
2467 PL_eval_root->op_private |= OPpREFCOUNTED;
2468 OpREFCNT_set(PL_eval_root, 1);
2469 PL_eval_root->op_next = 0;
2470 CALL_PEEP(PL_eval_start);
2473 if (o->op_type == OP_STUB) {
2474 PL_comppad_name = 0;
2476 S_op_destroy(aTHX_ o);
2479 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2480 PL_curcop = &PL_compiling;
2481 PL_main_start = LINKLIST(PL_main_root);
2482 PL_main_root->op_private |= OPpREFCOUNTED;
2483 OpREFCNT_set(PL_main_root, 1);
2484 PL_main_root->op_next = 0;
2485 CALL_PEEP(PL_main_start);
2488 /* Register with debugger */
2490 CV * const cv = get_cvs("DB::postponed", 0);
2494 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2496 call_sv(MUTABLE_SV(cv), G_DISCARD);
2503 Perl_localize(pTHX_ OP *o, I32 lex)
2507 PERL_ARGS_ASSERT_LOCALIZE;
2509 if (o->op_flags & OPf_PARENS)
2510 /* [perl #17376]: this appears to be premature, and results in code such as
2511 C< our(%x); > executing in list mode rather than void mode */
2518 if ( PL_parser->bufptr > PL_parser->oldbufptr
2519 && PL_parser->bufptr[-1] == ','
2520 && ckWARN(WARN_PARENTHESIS))
2522 char *s = PL_parser->bufptr;
2525 /* some heuristics to detect a potential error */
2526 while (*s && (strchr(", \t\n", *s)))
2530 if (*s && strchr("@$%*", *s) && *++s
2531 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2534 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2536 while (*s && (strchr(", \t\n", *s)))
2542 if (sigil && (*s == ';' || *s == '=')) {
2543 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2544 "Parentheses missing around \"%s\" list",
2546 ? (PL_parser->in_my == KEY_our
2548 : PL_parser->in_my == KEY_state
2558 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2559 PL_parser->in_my = FALSE;
2560 PL_parser->in_my_stash = NULL;
2565 Perl_jmaybe(pTHX_ OP *o)
2567 PERL_ARGS_ASSERT_JMAYBE;
2569 if (o->op_type == OP_LIST) {
2571 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2572 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2578 S_fold_constants(pTHX_ register OP *o)
2581 register OP * VOL curop;
2583 VOL I32 type = o->op_type;
2588 SV * const oldwarnhook = PL_warnhook;
2589 SV * const olddiehook = PL_diehook;
2593 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2595 if (PL_opargs[type] & OA_RETSCALAR)
2597 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2598 o->op_targ = pad_alloc(type, SVs_PADTMP);
2600 /* integerize op, unless it happens to be C<-foo>.
2601 * XXX should pp_i_negate() do magic string negation instead? */
2602 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2603 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2604 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2606 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2609 if (!(PL_opargs[type] & OA_FOLDCONST))
2614 /* XXX might want a ck_negate() for this */
2615 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2627 /* XXX what about the numeric ops? */
2628 if (PL_hints & HINT_LOCALE)
2633 if (PL_parser && PL_parser->error_count)
2634 goto nope; /* Don't try to run w/ errors */
2636 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2637 const OPCODE type = curop->op_type;
2638 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2640 type != OP_SCALAR &&
2642 type != OP_PUSHMARK)
2648 curop = LINKLIST(o);
2649 old_next = o->op_next;
2653 oldscope = PL_scopestack_ix;
2654 create_eval_scope(G_FAKINGEVAL);
2656 /* Verify that we don't need to save it: */
2657 assert(PL_curcop == &PL_compiling);
2658 StructCopy(&PL_compiling, ¬_compiling, COP);
2659 PL_curcop = ¬_compiling;
2660 /* The above ensures that we run with all the correct hints of the
2661 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2662 assert(IN_PERL_RUNTIME);
2663 PL_warnhook = PERL_WARNHOOK_FATAL;
2670 sv = *(PL_stack_sp--);
2671 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2672 pad_swipe(o->op_targ, FALSE);
2673 else if (SvTEMP(sv)) { /* grab mortal temp? */
2674 SvREFCNT_inc_simple_void(sv);
2679 /* Something tried to die. Abandon constant folding. */
2680 /* Pretend the error never happened. */
2682 o->op_next = old_next;
2686 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2687 PL_warnhook = oldwarnhook;
2688 PL_diehook = olddiehook;
2689 /* XXX note that this croak may fail as we've already blown away
2690 * the stack - eg any nested evals */
2691 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2694 PL_warnhook = oldwarnhook;
2695 PL_diehook = olddiehook;
2696 PL_curcop = &PL_compiling;
2698 if (PL_scopestack_ix > oldscope)
2699 delete_eval_scope();
2708 if (type == OP_RV2GV)
2709 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2711 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2712 op_getmad(o,newop,'f');
2720 S_gen_constant_list(pTHX_ register OP *o)
2724 const I32 oldtmps_floor = PL_tmps_floor;
2727 if (PL_parser && PL_parser->error_count)
2728 return o; /* Don't attempt to run with errors */
2730 PL_op = curop = LINKLIST(o);
2736 assert (!(curop->op_flags & OPf_SPECIAL));
2737 assert(curop->op_type == OP_RANGE);
2739 PL_tmps_floor = oldtmps_floor;
2741 o->op_type = OP_RV2AV;
2742 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2743 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2744 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2745 o->op_opt = 0; /* needs to be revisited in rpeep() */
2746 curop = ((UNOP*)o)->op_first;
2747 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2749 op_getmad(curop,o,'O');
2758 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2761 if (!o || o->op_type != OP_LIST)
2762 o = newLISTOP(OP_LIST, 0, o, NULL);
2764 o->op_flags &= ~OPf_WANT;
2766 if (!(PL_opargs[type] & OA_MARK))
2767 op_null(cLISTOPo->op_first);
2769 o->op_type = (OPCODE)type;
2770 o->op_ppaddr = PL_ppaddr[type];
2771 o->op_flags |= flags;
2773 o = CHECKOP(type, o);
2774 if (o->op_type != (unsigned)type)
2777 return fold_constants(o);
2781 =head1 Optree Manipulation Functions
2784 /* List constructors */
2787 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2789 Append an item to the list of ops contained directly within a list-type
2790 op, returning the lengthened list. I<first> is the list-type op,
2791 and I<last> is the op to append to the list. I<optype> specifies the
2792 intended opcode for the list. If I<first> is not already a list of the
2793 right type, it will be upgraded into one. If either I<first> or I<last>
2794 is null, the other is returned unchanged.
2800 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2808 if (first->op_type != (unsigned)type
2809 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2811 return newLISTOP(type, 0, first, last);
2814 if (first->op_flags & OPf_KIDS)
2815 ((LISTOP*)first)->op_last->op_sibling = last;
2817 first->op_flags |= OPf_KIDS;
2818 ((LISTOP*)first)->op_first = last;
2820 ((LISTOP*)first)->op_last = last;
2825 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2827 Concatenate the lists of ops contained directly within two list-type ops,
2828 returning the combined list. I<first> and I<last> are the list-type ops
2829 to concatenate. I<optype> specifies the intended opcode for the list.
2830 If either I<first> or I<last> is not already a list of the right type,
2831 it will be upgraded into one. If either I<first> or I<last> is null,
2832 the other is returned unchanged.
2838 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2846 if (first->op_type != (unsigned)type)
2847 return op_prepend_elem(type, first, last);
2849 if (last->op_type != (unsigned)type)
2850 return op_append_elem(type, first, last);
2852 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2853 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2854 first->op_flags |= (last->op_flags & OPf_KIDS);
2857 if (((LISTOP*)last)->op_first && first->op_madprop) {
2858 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2860 while (mp->mad_next)
2862 mp->mad_next = first->op_madprop;
2865 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2868 first->op_madprop = last->op_madprop;
2869 last->op_madprop = 0;
2872 S_op_destroy(aTHX_ last);
2878 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2880 Prepend an item to the list of ops contained directly within a list-type
2881 op, returning the lengthened list. I<first> is the op to prepend to the
2882 list, and I<last> is the list-type op. I<optype> specifies the intended
2883 opcode for the list. If I<last> is not already a list of the right type,
2884 it will be upgraded into one. If either I<first> or I<last> is null,
2885 the other is returned unchanged.
2891 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2899 if (last->op_type == (unsigned)type) {
2900 if (type == OP_LIST) { /* already a PUSHMARK there */
2901 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2902 ((LISTOP*)last)->op_first->op_sibling = first;
2903 if (!(first->op_flags & OPf_PARENS))
2904 last->op_flags &= ~OPf_PARENS;
2907 if (!(last->op_flags & OPf_KIDS)) {
2908 ((LISTOP*)last)->op_last = first;
2909 last->op_flags |= OPf_KIDS;
2911 first->op_sibling = ((LISTOP*)last)->op_first;
2912 ((LISTOP*)last)->op_first = first;
2914 last->op_flags |= OPf_KIDS;
2918 return newLISTOP(type, 0, first, last);
2926 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2929 Newxz(tk, 1, TOKEN);
2930 tk->tk_type = (OPCODE)optype;
2931 tk->tk_type = 12345;
2933 tk->tk_mad = madprop;
2938 Perl_token_free(pTHX_ TOKEN* tk)
2940 PERL_ARGS_ASSERT_TOKEN_FREE;
2942 if (tk->tk_type != 12345)
2944 mad_free(tk->tk_mad);
2949 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2954 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2956 if (tk->tk_type != 12345) {
2957 Perl_warner(aTHX_ packWARN(WARN_MISC),
2958 "Invalid TOKEN object ignored");
2965 /* faked up qw list? */
2967 tm->mad_type == MAD_SV &&
2968 SvPVX((SV *)tm->mad_val)[0] == 'q')
2975 /* pretend constant fold didn't happen? */
2976 if (mp->mad_key == 'f' &&
2977 (o->op_type == OP_CONST ||
2978 o->op_type == OP_GV) )
2980 token_getmad(tk,(OP*)mp->mad_val,slot);
2994 if (mp->mad_key == 'X')
2995 mp->mad_key = slot; /* just change the first one */
3005 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3014 /* pretend constant fold didn't happen? */
3015 if (mp->mad_key == 'f' &&
3016 (o->op_type == OP_CONST ||
3017 o->op_type == OP_GV) )
3019 op_getmad(from,(OP*)mp->mad_val,slot);
3026 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3029 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3035 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3044 /* pretend constant fold didn't happen? */
3045 if (mp->mad_key == 'f' &&
3046 (o->op_type == OP_CONST ||
3047 o->op_type == OP_GV) )
3049 op_getmad(from,(OP*)mp->mad_val,slot);
3056 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3059 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3063 PerlIO_printf(PerlIO_stderr(),
3064 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3070 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3088 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3092 addmad(tm, &(o->op_madprop), slot);
3096 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3117 Perl_newMADsv(pTHX_ char key, SV* sv)
3119 PERL_ARGS_ASSERT_NEWMADSV;
3121 return newMADPROP(key, MAD_SV, sv, 0);
3125 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3128 Newxz(mp, 1, MADPROP);
3131 mp->mad_vlen = vlen;
3132 mp->mad_type = type;
3134 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3139 Perl_mad_free(pTHX_ MADPROP* mp)
3141 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3145 mad_free(mp->mad_next);
3146 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3147 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3148 switch (mp->mad_type) {
3152 Safefree((char*)mp->mad_val);
3155 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3156 op_free((OP*)mp->mad_val);
3159 sv_free(MUTABLE_SV(mp->mad_val));
3162 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3171 =head1 Optree construction
3173 =for apidoc Am|OP *|newNULLLIST
3175 Constructs, checks, and returns a new C<stub> op, which represents an
3176 empty list expression.
3182 Perl_newNULLLIST(pTHX)
3184 return newOP(OP_STUB, 0);
3188 S_force_list(pTHX_ OP *o)
3190 if (!o || o->op_type != OP_LIST)
3191 o = newLISTOP(OP_LIST, 0, o, NULL);
3197 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3199 Constructs, checks, and returns an op of any list type. I<type> is
3200 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3201 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3202 supply up to two ops to be direct children of the list op; they are
3203 consumed by this function and become part of the constructed op tree.
3209 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3214 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3216 NewOp(1101, listop, 1, LISTOP);
3218 listop->op_type = (OPCODE)type;
3219 listop->op_ppaddr = PL_ppaddr[type];
3222 listop->op_flags = (U8)flags;
3226 else if (!first && last)
3229 first->op_sibling = last;
3230 listop->op_first = first;
3231 listop->op_last = last;
3232 if (type == OP_LIST) {
3233 OP* const pushop = newOP(OP_PUSHMARK, 0);
3234 pushop->op_sibling = first;
3235 listop->op_first = pushop;
3236 listop->op_flags |= OPf_KIDS;
3238 listop->op_last = pushop;
3241 return CHECKOP(type, listop);
3245 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3247 Constructs, checks, and returns an op of any base type (any type that
3248 has no extra fields). I<type> is the opcode. I<flags> gives the
3249 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3256 Perl_newOP(pTHX_ I32 type, I32 flags)
3261 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3262 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3263 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3264 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3266 NewOp(1101, o, 1, OP);
3267 o->op_type = (OPCODE)type;
3268 o->op_ppaddr = PL_ppaddr[type];
3269 o->op_flags = (U8)flags;
3271 o->op_latefreed = 0;
3275 o->op_private = (U8)(0 | (flags >> 8));
3276 if (PL_opargs[type] & OA_RETSCALAR)
3278 if (PL_opargs[type] & OA_TARGET)
3279 o->op_targ = pad_alloc(type, SVs_PADTMP);
3280 return CHECKOP(type, o);
3284 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3286 Constructs, checks, and returns an op of any unary type. I<type> is
3287 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3288 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3289 bits, the eight bits of C<op_private>, except that the bit with value 1
3290 is automatically set. I<first> supplies an optional op to be the direct
3291 child of the unary op; it is consumed by this function and become part
3292 of the constructed op tree.
3298 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3303 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3304 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3305 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3306 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3307 || type == OP_SASSIGN
3308 || type == OP_ENTERTRY
3309 || type == OP_NULL );
3312 first = newOP(OP_STUB, 0);
3313 if (PL_opargs[type] & OA_MARK)
3314 first = force_list(first);
3316 NewOp(1101, unop, 1, UNOP);
3317 unop->op_type = (OPCODE)type;
3318 unop->op_ppaddr = PL_ppaddr[type];
3319 unop->op_first = first;
3320 unop->op_flags = (U8)(flags | OPf_KIDS);
3321 unop->op_private = (U8)(1 | (flags >> 8));
3322 unop = (UNOP*) CHECKOP(type, unop);
3326 return fold_constants((OP *) unop);
3330 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3332 Constructs, checks, and returns an op of any binary type. I<type>
3333 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3334 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3335 the eight bits of C<op_private>, except that the bit with value 1 or
3336 2 is automatically set as required. I<first> and I<last> supply up to
3337 two ops to be the direct children of the binary op; they are consumed
3338 by this function and become part of the constructed op tree.
3344 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3349 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3350 || type == OP_SASSIGN || type == OP_NULL );
3352 NewOp(1101, binop, 1, BINOP);
3355 first = newOP(OP_NULL, 0);
3357 binop->op_type = (OPCODE)type;
3358 binop->op_ppaddr = PL_ppaddr[type];
3359 binop->op_first = first;
3360 binop->op_flags = (U8)(flags | OPf_KIDS);
3363 binop->op_private = (U8)(1 | (flags >> 8));
3366 binop->op_private = (U8)(2 | (flags >> 8));
3367 first->op_sibling = last;
3370 binop = (BINOP*)CHECKOP(type, binop);
3371 if (binop->op_next || binop->op_type != (OPCODE)type)
3374 binop->op_last = binop->op_first->op_sibling;
3376 return fold_constants((OP *)binop);
3379 static int uvcompare(const void *a, const void *b)
3380 __attribute__nonnull__(1)
3381 __attribute__nonnull__(2)
3382 __attribute__pure__;
3383 static int uvcompare(const void *a, const void *b)
3385 if (*((const UV *)a) < (*(const UV *)b))
3387 if (*((const UV *)a) > (*(const UV *)b))
3389 if (*((const UV *)a+1) < (*(const UV *)b+1))
3391 if (*((const UV *)a+1) > (*(const UV *)b+1))
3397 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3400 SV * const tstr = ((SVOP*)expr)->op_sv;
3403 (repl->op_type == OP_NULL)
3404 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3406 ((SVOP*)repl)->op_sv;
3409 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3410 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3414 register short *tbl;
3416 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3417 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3418 I32 del = o->op_private & OPpTRANS_DELETE;
3421 PERL_ARGS_ASSERT_PMTRANS;
3423 PL_hints |= HINT_BLOCK_SCOPE;
3426 o->op_private |= OPpTRANS_FROM_UTF;
3429 o->op_private |= OPpTRANS_TO_UTF;
3431 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3432 SV* const listsv = newSVpvs("# comment\n");
3434 const U8* tend = t + tlen;
3435 const U8* rend = r + rlen;
3449 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3450 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3453 const U32 flags = UTF8_ALLOW_DEFAULT;
3457 t = tsave = bytes_to_utf8(t, &len);
3460 if (!to_utf && rlen) {
3462 r = rsave = bytes_to_utf8(r, &len);
3466 /* There are several snags with this code on EBCDIC:
3467 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3468 2. scan_const() in toke.c has encoded chars in native encoding which makes
3469 ranges at least in EBCDIC 0..255 range the bottom odd.
3473 U8 tmpbuf[UTF8_MAXBYTES+1];
3476 Newx(cp, 2*tlen, UV);
3478 transv = newSVpvs("");
3480 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3482 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3484 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3488 cp[2*i+1] = cp[2*i];
3492 qsort(cp, i, 2*sizeof(UV), uvcompare);
3493 for (j = 0; j < i; j++) {
3495 diff = val - nextmin;
3497 t = uvuni_to_utf8(tmpbuf,nextmin);
3498 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3500 U8 range_mark = UTF_TO_NATIVE(0xff);
3501 t = uvuni_to_utf8(tmpbuf, val - 1);
3502 sv_catpvn(transv, (char *)&range_mark, 1);
3503 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3510 t = uvuni_to_utf8(tmpbuf,nextmin);
3511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3513 U8 range_mark = UTF_TO_NATIVE(0xff);
3514 sv_catpvn(transv, (char *)&range_mark, 1);
3516 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3517 UNICODE_ALLOW_SUPER);
3518 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3519 t = (const U8*)SvPVX_const(transv);
3520 tlen = SvCUR(transv);
3524 else if (!rlen && !del) {
3525 r = t; rlen = tlen; rend = tend;
3528 if ((!rlen && !del) || t == r ||
3529 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3531 o->op_private |= OPpTRANS_IDENTICAL;
3535 while (t < tend || tfirst <= tlast) {
3536 /* see if we need more "t" chars */
3537 if (tfirst > tlast) {
3538 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3540 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3542 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3549 /* now see if we need more "r" chars */
3550 if (rfirst > rlast) {
3552 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3554 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3556 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3565 rfirst = rlast = 0xffffffff;
3569 /* now see which range will peter our first, if either. */
3570 tdiff = tlast - tfirst;
3571 rdiff = rlast - rfirst;
3578 if (rfirst == 0xffffffff) {
3579 diff = tdiff; /* oops, pretend rdiff is infinite */
3581 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3582 (long)tfirst, (long)tlast);
3584 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3588 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3589 (long)tfirst, (long)(tfirst + diff),
3592 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3593 (long)tfirst, (long)rfirst);
3595 if (rfirst + diff > max)
3596 max = rfirst + diff;
3598 grows = (tfirst < rfirst &&
3599 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3611 else if (max > 0xff)
3616 PerlMemShared_free(cPVOPo->op_pv);
3617 cPVOPo->op_pv = NULL;
3619 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3621 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3622 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3623 PAD_SETSV(cPADOPo->op_padix, swash);
3625 SvREADONLY_on(swash);
3627 cSVOPo->op_sv = swash;
3629 SvREFCNT_dec(listsv);
3630 SvREFCNT_dec(transv);
3632 if (!del && havefinal && rlen)
3633 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3634 newSVuv((UV)final), 0);
3637 o->op_private |= OPpTRANS_GROWS;
3643 op_getmad(expr,o,'e');
3644 op_getmad(repl,o,'r');
3652 tbl = (short*)cPVOPo->op_pv;
3654 Zero(tbl, 256, short);
3655 for (i = 0; i < (I32)tlen; i++)
3657 for (i = 0, j = 0; i < 256; i++) {
3659 if (j >= (I32)rlen) {
3668 if (i < 128 && r[j] >= 128)
3678 o->op_private |= OPpTRANS_IDENTICAL;
3680 else if (j >= (I32)rlen)
3685 PerlMemShared_realloc(tbl,
3686 (0x101+rlen-j) * sizeof(short));
3687 cPVOPo->op_pv = (char*)tbl;
3689 tbl[0x100] = (short)(rlen - j);
3690 for (i=0; i < (I32)rlen - j; i++)
3691 tbl[0x101+i] = r[j+i];
3695 if (!rlen && !del) {
3698 o->op_private |= OPpTRANS_IDENTICAL;
3700 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3701 o->op_private |= OPpTRANS_IDENTICAL;
3703 for (i = 0; i < 256; i++)
3705 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3706 if (j >= (I32)rlen) {
3708 if (tbl[t[i]] == -1)
3714 if (tbl[t[i]] == -1) {
3715 if (t[i] < 128 && r[j] >= 128)
3722 if(del && rlen == tlen) {
3723 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3724 } else if(rlen > tlen) {
3725 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3729 o->op_private |= OPpTRANS_GROWS;
3731 op_getmad(expr,o,'e');
3732 op_getmad(repl,o,'r');
3742 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3744 Constructs, checks, and returns an op of any pattern matching type.
3745 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3746 and, shifted up eight bits, the eight bits of C<op_private>.
3752 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3759 NewOp(1101, pmop, 1, PMOP);
3760 pmop->op_type = (OPCODE)type;
3761 pmop->op_ppaddr = PL_ppaddr[type];
3762 pmop->op_flags = (U8)flags;
3763 pmop->op_private = (U8)(0 | (flags >> 8));
3765 if (PL_hints & HINT_RE_TAINT)
3766 pmop->op_pmflags |= PMf_RETAINT;
3767 if (PL_hints & HINT_LOCALE) {
3768 pmop->op_pmflags |= PMf_LOCALE;
3770 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3771 pmop->op_pmflags |= RXf_PMf_UNICODE;
3773 if (PL_hints & HINT_RE_FLAGS) {
3774 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3775 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3777 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3778 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3779 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3781 if (reflags && SvOK(reflags)) {
3782 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3783 pmop->op_pmflags |= SvIV(reflags);
3789 assert(SvPOK(PL_regex_pad[0]));
3790 if (SvCUR(PL_regex_pad[0])) {
3791 /* Pop off the "packed" IV from the end. */
3792 SV *const repointer_list = PL_regex_pad[0];
3793 const char *p = SvEND(repointer_list) - sizeof(IV);
3794 const IV offset = *((IV*)p);
3796 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3798 SvEND_set(repointer_list, p);
3800 pmop->op_pmoffset = offset;
3801 /* This slot should be free, so assert this: */
3802 assert(PL_regex_pad[offset] == &PL_sv_undef);
3804 SV * const repointer = &PL_sv_undef;
3805 av_push(PL_regex_padav, repointer);
3806 pmop->op_pmoffset = av_len(PL_regex_padav);
3807 PL_regex_pad = AvARRAY(PL_regex_padav);
3811 return CHECKOP(type, pmop);
3814 /* Given some sort of match op o, and an expression expr containing a
3815 * pattern, either compile expr into a regex and attach it to o (if it's
3816 * constant), or convert expr into a runtime regcomp op sequence (if it's
3819 * isreg indicates that the pattern is part of a regex construct, eg
3820 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3821 * split "pattern", which aren't. In the former case, expr will be a list
3822 * if the pattern contains more than one term (eg /a$b/) or if it contains
3823 * a replacement, ie s/// or tr///.
3827 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3832 I32 repl_has_vars = 0;
3836 PERL_ARGS_ASSERT_PMRUNTIME;
3839 o->op_type == OP_SUBST
3840 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
3842 /* last element in list is the replacement; pop it */
3844 repl = cLISTOPx(expr)->op_last;
3845 kid = cLISTOPx(expr)->op_first;
3846 while (kid->op_sibling != repl)
3847 kid = kid->op_sibling;
3848 kid->op_sibling = NULL;
3849 cLISTOPx(expr)->op_last = kid;
3852 if (isreg && expr->op_type == OP_LIST &&
3853 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3855 /* convert single element list to element */
3856 OP* const oe = expr;
3857 expr = cLISTOPx(oe)->op_first->op_sibling;
3858 cLISTOPx(oe)->op_first->op_sibling = NULL;
3859 cLISTOPx(oe)->op_last = NULL;
3863 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
3864 return pmtrans(o, expr, repl);
3867 reglist = isreg && expr->op_type == OP_LIST;
3871 PL_hints |= HINT_BLOCK_SCOPE;
3874 if (expr->op_type == OP_CONST) {
3875 SV *pat = ((SVOP*)expr)->op_sv;
3876 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3878 if (o->op_flags & OPf_SPECIAL)
3879 pm_flags |= RXf_SPLIT;
3882 assert (SvUTF8(pat));
3883 } else if (SvUTF8(pat)) {
3884 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3885 trapped in use 'bytes'? */
3886 /* Make a copy of the octet sequence, but without the flag on, as
3887 the compiler now honours the SvUTF8 flag on pat. */
3889 const char *const p = SvPV(pat, len);
3890 pat = newSVpvn_flags(p, len, SVs_TEMP);
3893 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3896 op_getmad(expr,(OP*)pm,'e');
3902 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3903 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3905 : OP_REGCMAYBE),0,expr);
3907 NewOp(1101, rcop, 1, LOGOP);
3908 rcop->op_type = OP_REGCOMP;
3909 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3910 rcop->op_first = scalar(expr);
3911 rcop->op_flags |= OPf_KIDS
3912 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3913 | (reglist ? OPf_STACKED : 0);
3914 rcop->op_private = 1;
3917 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3919 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3922 /* establish postfix order */
3923 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3925 rcop->op_next = expr;
3926 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3929 rcop->op_next = LINKLIST(expr);
3930 expr->op_next = (OP*)rcop;
3933 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3938 if (pm->op_pmflags & PMf_EVAL) {
3940 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3941 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3943 else if (repl->op_type == OP_CONST)
3947 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3948 if (curop->op_type == OP_SCOPE
3949 || curop->op_type == OP_LEAVE
3950 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3951 if (curop->op_type == OP_GV) {
3952 GV * const gv = cGVOPx_gv(curop);
3954 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3957 else if (curop->op_type == OP_RV2CV)
3959 else if (curop->op_type == OP_RV2SV ||
3960 curop->op_type == OP_RV2AV ||
3961 curop->op_type == OP_RV2HV ||
3962 curop->op_type == OP_RV2GV) {
3963 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3966 else if (curop->op_type == OP_PADSV ||
3967 curop->op_type == OP_PADAV ||
3968 curop->op_type == OP_PADHV ||
3969 curop->op_type == OP_PADANY)
3973 else if (curop->op_type == OP_PUSHRE)
3974 NOOP; /* Okay here, dangerous in newASSIGNOP */
3984 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3986 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3987 op_prepend_elem(o->op_type, scalar(repl), o);
3990 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3991 pm->op_pmflags |= PMf_MAYBE_CONST;
3993 NewOp(1101, rcop, 1, LOGOP);
3994 rcop->op_type = OP_SUBSTCONT;
3995 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3996 rcop->op_first = scalar(repl);
3997 rcop->op_flags |= OPf_KIDS;
3998 rcop->op_private = 1;
4001 /* establish postfix order */
4002 rcop->op_next = LINKLIST(repl);
4003 repl->op_next = (OP*)rcop;
4005 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4006 assert(!(pm->op_pmflags & PMf_ONCE));
4007 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4016 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4018 Constructs, checks, and returns an op of any type that involves an
4019 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4020 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4021 takes ownership of one reference to it.
4027 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4032 PERL_ARGS_ASSERT_NEWSVOP;
4034 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4035 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4036 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4038 NewOp(1101, svop, 1, SVOP);
4039 svop->op_type = (OPCODE)type;
4040 svop->op_ppaddr = PL_ppaddr[type];
4042 svop->op_next = (OP*)svop;
4043 svop->op_flags = (U8)flags;
4044 if (PL_opargs[type] & OA_RETSCALAR)
4046 if (PL_opargs[type] & OA_TARGET)
4047 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4048 return CHECKOP(type, svop);
4054 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4056 Constructs, checks, and returns an op of any type that involves a
4057 reference to a pad element. I<type> is the opcode. I<flags> gives the
4058 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4059 is populated with I<sv>; this function takes ownership of one reference
4062 This function only exists if Perl has been compiled to use ithreads.
4068 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4073 PERL_ARGS_ASSERT_NEWPADOP;
4075 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4076 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4077 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4079 NewOp(1101, padop, 1, PADOP);
4080 padop->op_type = (OPCODE)type;
4081 padop->op_ppaddr = PL_ppaddr[type];
4082 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4083 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4084 PAD_SETSV(padop->op_padix, sv);
4087 padop->op_next = (OP*)padop;
4088 padop->op_flags = (U8)flags;
4089 if (PL_opargs[type] & OA_RETSCALAR)
4091 if (PL_opargs[type] & OA_TARGET)
4092 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4093 return CHECKOP(type, padop);
4096 #endif /* !USE_ITHREADS */
4099 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4101 Constructs, checks, and returns an op of any type that involves an
4102 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4103 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4104 reference; calling this function does not transfer ownership of any
4111 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4115 PERL_ARGS_ASSERT_NEWGVOP;
4119 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4121 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4126 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4128 Constructs, checks, and returns an op of any type that involves an
4129 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4130 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4131 must have been allocated using L</PerlMemShared_malloc>; the memory will
4132 be freed when the op is destroyed.
4138 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4143 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4144 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4146 NewOp(1101, pvop, 1, PVOP);
4147 pvop->op_type = (OPCODE)type;
4148 pvop->op_ppaddr = PL_ppaddr[type];
4150 pvop->op_next = (OP*)pvop;
4151 pvop->op_flags = (U8)flags;
4152 if (PL_opargs[type] & OA_RETSCALAR)
4154 if (PL_opargs[type] & OA_TARGET)
4155 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4156 return CHECKOP(type, pvop);
4164 Perl_package(pTHX_ OP *o)
4167 SV *const sv = cSVOPo->op_sv;
4172 PERL_ARGS_ASSERT_PACKAGE;
4174 save_hptr(&PL_curstash);
4175 save_item(PL_curstname);
4177 PL_curstash = gv_stashsv(sv, GV_ADD);
4179 sv_setsv(PL_curstname, sv);
4181 PL_hints |= HINT_BLOCK_SCOPE;
4182 PL_parser->copline = NOLINE;
4183 PL_parser->expect = XSTATE;
4188 if (!PL_madskills) {
4193 pegop = newOP(OP_NULL,0);
4194 op_getmad(o,pegop,'P');
4200 Perl_package_version( pTHX_ OP *v )
4203 U32 savehints = PL_hints;
4204 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4205 PL_hints &= ~HINT_STRICT_VARS;
4206 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4207 PL_hints = savehints;
4216 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4223 OP *pegop = newOP(OP_NULL,0);
4226 PERL_ARGS_ASSERT_UTILIZE;
4228 if (idop->op_type != OP_CONST)
4229 Perl_croak(aTHX_ "Module name must be constant");
4232 op_getmad(idop,pegop,'U');
4237 SV * const vesv = ((SVOP*)version)->op_sv;
4240 op_getmad(version,pegop,'V');
4241 if (!arg && !SvNIOKp(vesv)) {
4248 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4249 Perl_croak(aTHX_ "Version number must be a constant number");
4251 /* Make copy of idop so we don't free it twice */
4252 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4254 /* Fake up a method call to VERSION */
4255 meth = newSVpvs_share("VERSION");
4256 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4257 op_append_elem(OP_LIST,
4258 op_prepend_elem(OP_LIST, pack, list(version)),
4259 newSVOP(OP_METHOD_NAMED, 0, meth)));
4263 /* Fake up an import/unimport */
4264 if (arg && arg->op_type == OP_STUB) {
4266 op_getmad(arg,pegop,'S');
4267 imop = arg; /* no import on explicit () */
4269 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4270 imop = NULL; /* use 5.0; */
4272 idop->op_private |= OPpCONST_NOVER;
4278 op_getmad(arg,pegop,'A');
4280 /* Make copy of idop so we don't free it twice */
4281 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4283 /* Fake up a method call to import/unimport */
4285 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4286 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4287 op_append_elem(OP_LIST,
4288 op_prepend_elem(OP_LIST, pack, list(arg)),
4289 newSVOP(OP_METHOD_NAMED, 0, meth)));
4292 /* Fake up the BEGIN {}, which does its thing immediately. */
4294 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4297 op_append_elem(OP_LINESEQ,
4298 op_append_elem(OP_LINESEQ,
4299 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4300 newSTATEOP(0, NULL, veop)),
4301 newSTATEOP(0, NULL, imop) ));
4303 /* The "did you use incorrect case?" warning used to be here.
4304 * The problem is that on case-insensitive filesystems one
4305 * might get false positives for "use" (and "require"):
4306 * "use Strict" or "require CARP" will work. This causes
4307 * portability problems for the script: in case-strict
4308 * filesystems the script will stop working.
4310 * The "incorrect case" warning checked whether "use Foo"
4311 * imported "Foo" to your namespace, but that is wrong, too:
4312 * there is no requirement nor promise in the language that
4313 * a Foo.pm should or would contain anything in package "Foo".
4315 * There is very little Configure-wise that can be done, either:
4316 * the case-sensitivity of the build filesystem of Perl does not
4317 * help in guessing the case-sensitivity of the runtime environment.
4320 PL_hints |= HINT_BLOCK_SCOPE;
4321 PL_parser->copline = NOLINE;
4322 PL_parser->expect = XSTATE;
4323 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4326 if (!PL_madskills) {
4327 /* FIXME - don't allocate pegop if !PL_madskills */
4336 =head1 Embedding Functions
4338 =for apidoc load_module
4340 Loads the module whose name is pointed to by the string part of name.
4341 Note that the actual module name, not its filename, should be given.
4342 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4343 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4344 (or 0 for no flags). ver, if specified, provides version semantics
4345 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4346 arguments can be used to specify arguments to the module's import()
4347 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4348 terminated with a final NULL pointer. Note that this list can only
4349 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4350 Otherwise at least a single NULL pointer to designate the default
4351 import list is required.
4356 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4360 PERL_ARGS_ASSERT_LOAD_MODULE;
4362 va_start(args, ver);
4363 vload_module(flags, name, ver, &args);
4367 #ifdef PERL_IMPLICIT_CONTEXT
4369 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4373 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4374 va_start(args, ver);
4375 vload_module(flags, name, ver, &args);
4381 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4385 OP * const modname = newSVOP(OP_CONST, 0, name);
4387 PERL_ARGS_ASSERT_VLOAD_MODULE;
4389 modname->op_private |= OPpCONST_BARE;
4391 veop = newSVOP(OP_CONST, 0, ver);
4395 if (flags & PERL_LOADMOD_NOIMPORT) {
4396 imop = sawparens(newNULLLIST());
4398 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4399 imop = va_arg(*args, OP*);
4404 sv = va_arg(*args, SV*);
4406 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4407 sv = va_arg(*args, SV*);
4411 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4412 * that it has a PL_parser to play with while doing that, and also
4413 * that it doesn't mess with any existing parser, by creating a tmp
4414 * new parser with lex_start(). This won't actually be used for much,
4415 * since pp_require() will create another parser for the real work. */
4418 SAVEVPTR(PL_curcop);
4419 lex_start(NULL, NULL, 0);
4420 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4421 veop, modname, imop);
4426 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4432 PERL_ARGS_ASSERT_DOFILE;
4434 if (!force_builtin) {
4435 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4436 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4437 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4438 gv = gvp ? *gvp : NULL;
4442 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4443 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4444 op_append_elem(OP_LIST, term,
4445 scalar(newUNOP(OP_RV2CV, 0,
4446 newGVOP(OP_GV, 0, gv))))));
4449 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4455 =head1 Optree construction
4457 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4459 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4460 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4461 be set automatically, and, shifted up eight bits, the eight bits of
4462 C<op_private>, except that the bit with value 1 or 2 is automatically
4463 set as required. I<listval> and I<subscript> supply the parameters of
4464 the slice; they are consumed by this function and become part of the
4465 constructed op tree.
4471 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4473 return newBINOP(OP_LSLICE, flags,
4474 list(force_list(subscript)),
4475 list(force_list(listval)) );
4479 S_is_list_assignment(pTHX_ register const OP *o)
4487 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4488 o = cUNOPo->op_first;
4490 flags = o->op_flags;
4492 if (type == OP_COND_EXPR) {
4493 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4494 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4499 yyerror("Assignment to both a list and a scalar");
4503 if (type == OP_LIST &&
4504 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4505 o->op_private & OPpLVAL_INTRO)
4508 if (type == OP_LIST || flags & OPf_PARENS ||
4509 type == OP_RV2AV || type == OP_RV2HV ||
4510 type == OP_ASLICE || type == OP_HSLICE)
4513 if (type == OP_PADAV || type == OP_PADHV)
4516 if (type == OP_RV2SV)
4523 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4525 Constructs, checks, and returns an assignment op. I<left> and I<right>
4526 supply the parameters of the assignment; they are consumed by this
4527 function and become part of the constructed op tree.
4529 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4530 a suitable conditional optree is constructed. If I<optype> is the opcode
4531 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4532 performs the binary operation and assigns the result to the left argument.
4533 Either way, if I<optype> is non-zero then I<flags> has no effect.
4535 If I<optype> is zero, then a plain scalar or list assignment is
4536 constructed. Which type of assignment it is is automatically determined.
4537 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4538 will be set automatically, and, shifted up eight bits, the eight bits
4539 of C<op_private>, except that the bit with value 1 or 2 is automatically
4546 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4552 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4553 return newLOGOP(optype, 0,
4554 op_lvalue(scalar(left), optype),
4555 newUNOP(OP_SASSIGN, 0, scalar(right)));
4558 return newBINOP(optype, OPf_STACKED,
4559 op_lvalue(scalar(left), optype), scalar(right));
4563 if (is_list_assignment(left)) {
4564 static const char no_list_state[] = "Initialization of state variables"
4565 " in list context currently forbidden";
4567 bool maybe_common_vars = TRUE;
4570 /* Grandfathering $[ assignment here. Bletch.*/
4571 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4572 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4573 left = op_lvalue(left, OP_AASSIGN);
4576 else if (left->op_type == OP_CONST) {
4577 deprecate("assignment to $[");
4579 /* Result of assignment is always 1 (or we'd be dead already) */
4580 return newSVOP(OP_CONST, 0, newSViv(1));
4582 curop = list(force_list(left));
4583 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4584 o->op_private = (U8)(0 | (flags >> 8));
4586 if ((left->op_type == OP_LIST
4587 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4589 OP* lop = ((LISTOP*)left)->op_first;
4590 maybe_common_vars = FALSE;
4592 if (lop->op_type == OP_PADSV ||
4593 lop->op_type == OP_PADAV ||
4594 lop->op_type == OP_PADHV ||
4595 lop->op_type == OP_PADANY) {
4596 if (!(lop->op_private & OPpLVAL_INTRO))
4597 maybe_common_vars = TRUE;
4599 if (lop->op_private & OPpPAD_STATE) {
4600 if (left->op_private & OPpLVAL_INTRO) {
4601 /* Each variable in state($a, $b, $c) = ... */
4604 /* Each state variable in
4605 (state $a, my $b, our $c, $d, undef) = ... */
4607 yyerror(no_list_state);
4609 /* Each my variable in
4610 (state $a, my $b, our $c, $d, undef) = ... */
4612 } else if (lop->op_type == OP_UNDEF ||
4613 lop->op_type == OP_PUSHMARK) {
4614 /* undef may be interesting in
4615 (state $a, undef, state $c) */
4617 /* Other ops in the list. */
4618 maybe_common_vars = TRUE;
4620 lop = lop->op_sibling;
4623 else if ((left->op_private & OPpLVAL_INTRO)
4624 && ( left->op_type == OP_PADSV
4625 || left->op_type == OP_PADAV
4626 || left->op_type == OP_PADHV
4627 || left->op_type == OP_PADANY))
4629 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4630 if (left->op_private & OPpPAD_STATE) {
4631 /* All single variable list context state assignments, hence
4641 yyerror(no_list_state);
4645 /* PL_generation sorcery:
4646 * an assignment like ($a,$b) = ($c,$d) is easier than
4647 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4648 * To detect whether there are common vars, the global var
4649 * PL_generation is incremented for each assign op we compile.
4650 * Then, while compiling the assign op, we run through all the
4651 * variables on both sides of the assignment, setting a spare slot
4652 * in each of them to PL_generation. If any of them already have
4653 * that value, we know we've got commonality. We could use a
4654 * single bit marker, but then we'd have to make 2 passes, first
4655 * to clear the flag, then to test and set it. To find somewhere
4656 * to store these values, evil chicanery is done with SvUVX().
4659 if (maybe_common_vars) {
4662 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4663 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4664 if (curop->op_type == OP_GV) {
4665 GV *gv = cGVOPx_gv(curop);
4667 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4669 GvASSIGN_GENERATION_set(gv, PL_generation);
4671 else if (curop->op_type == OP_PADSV ||
4672 curop->op_type == OP_PADAV ||
4673 curop->op_type == OP_PADHV ||
4674 curop->op_type == OP_PADANY)
4676 if (PAD_COMPNAME_GEN(curop->op_targ)
4677 == (STRLEN)PL_generation)
4679 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4682 else if (curop->op_type == OP_RV2CV)
4684 else if (curop->op_type == OP_RV2SV ||
4685 curop->op_type == OP_RV2AV ||
4686 curop->op_type == OP_RV2HV ||
4687 curop->op_type == OP_RV2GV) {
4688 if (lastop->op_type != OP_GV) /* funny deref? */
4691 else if (curop->op_type == OP_PUSHRE) {
4693 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4694 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4696 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4698 GvASSIGN_GENERATION_set(gv, PL_generation);
4702 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4705 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4707 GvASSIGN_GENERATION_set(gv, PL_generation);
4717 o->op_private |= OPpASSIGN_COMMON;
4720 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4721 OP* tmpop = ((LISTOP*)right)->op_first;
4722 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4723 PMOP * const pm = (PMOP*)tmpop;
4724 if (left->op_type == OP_RV2AV &&
4725 !(left->op_private & OPpLVAL_INTRO) &&
4726 !(o->op_private & OPpASSIGN_COMMON) )
4728 tmpop = ((UNOP*)left)->op_first;
4729 if (tmpop->op_type == OP_GV
4731 && !pm->op_pmreplrootu.op_pmtargetoff
4733 && !pm->op_pmreplrootu.op_pmtargetgv
4737 pm->op_pmreplrootu.op_pmtargetoff
4738 = cPADOPx(tmpop)->op_padix;
4739 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4741 pm->op_pmreplrootu.op_pmtargetgv
4742 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4743 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4745 pm->op_pmflags |= PMf_ONCE;
4746 tmpop = cUNOPo->op_first; /* to list (nulled) */
4747 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4748 tmpop->op_sibling = NULL; /* don't free split */
4749 right->op_next = tmpop->op_next; /* fix starting loc */
4750 op_free(o); /* blow off assign */
4751 right->op_flags &= ~OPf_WANT;
4752 /* "I don't know and I don't care." */
4757 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4758 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4760 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4761 if (SvIOK(sv) && SvIVX(sv) == 0)
4762 sv_setiv(sv, PL_modcount+1);
4770 right = newOP(OP_UNDEF, 0);
4771 if (right->op_type == OP_READLINE) {
4772 right->op_flags |= OPf_STACKED;
4773 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
4777 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4778 o = newBINOP(OP_SASSIGN, flags,
4779 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
4783 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4784 deprecate("assignment to $[");
4786 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4787 o->op_private |= OPpCONST_ARYBASE;
4795 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4797 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4798 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4799 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4800 If I<label> is non-null, it supplies the name of a label to attach to
4801 the state op; this function takes ownership of the memory pointed at by
4802 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4805 If I<o> is null, the state op is returned. Otherwise the state op is
4806 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4807 is consumed by this function and becomes part of the returned op tree.
4813 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4816 const U32 seq = intro_my();
4819 NewOp(1101, cop, 1, COP);
4820 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4821 cop->op_type = OP_DBSTATE;
4822 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4825 cop->op_type = OP_NEXTSTATE;
4826 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4828 cop->op_flags = (U8)flags;
4829 CopHINTS_set(cop, PL_hints);
4831 cop->op_private |= NATIVE_HINTS;
4833 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4834 cop->op_next = (OP*)cop;
4837 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4838 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4840 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4841 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4843 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4845 PL_hints |= HINT_BLOCK_SCOPE;
4846 /* It seems that we need to defer freeing this pointer, as other parts
4847 of the grammar end up wanting to copy it after this op has been
4852 if (PL_parser && PL_parser->copline == NOLINE)
4853 CopLINE_set(cop, CopLINE(PL_curcop));
4855 CopLINE_set(cop, PL_parser->copline);
4857 PL_parser->copline = NOLINE;
4860 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4862 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4864 CopSTASH_set(cop, PL_curstash);
4866 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4867 /* this line can have a breakpoint - store the cop in IV */
4868 AV *av = CopFILEAVx(PL_curcop);
4870 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4871 if (svp && *svp != &PL_sv_undef ) {
4872 (void)SvIOK_on(*svp);
4873 SvIV_set(*svp, PTR2IV(cop));
4878 if (flags & OPf_SPECIAL)
4880 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4884 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4886 Constructs, checks, and returns a logical (flow control) op. I<type>
4887 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4888 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4889 the eight bits of C<op_private>, except that the bit with value 1 is
4890 automatically set. I<first> supplies the expression controlling the
4891 flow, and I<other> supplies the side (alternate) chain of ops; they are
4892 consumed by this function and become part of the constructed op tree.
4898 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4902 PERL_ARGS_ASSERT_NEWLOGOP;
4904 return new_logop(type, flags, &first, &other);
4908 S_search_const(pTHX_ OP *o)
4910 PERL_ARGS_ASSERT_SEARCH_CONST;
4912 switch (o->op_type) {
4916 if (o->op_flags & OPf_KIDS)
4917 return search_const(cUNOPo->op_first);
4924 if (!(o->op_flags & OPf_KIDS))
4926 kid = cLISTOPo->op_first;
4928 switch (kid->op_type) {
4932 kid = kid->op_sibling;
4935 if (kid != cLISTOPo->op_last)
4941 kid = cLISTOPo->op_last;
4943 return search_const(kid);
4951 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4959 int prepend_not = 0;
4961 PERL_ARGS_ASSERT_NEW_LOGOP;
4966 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4967 return newBINOP(type, flags, scalar(first), scalar(other));
4969 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4971 scalarboolean(first);
4972 /* optimize AND and OR ops that have NOTs as children */
4973 if (first->op_type == OP_NOT
4974 && (first->op_flags & OPf_KIDS)
4975 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4976 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4978 if (type == OP_AND || type == OP_OR) {
4984 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4986 prepend_not = 1; /* prepend a NOT op later */
4990 /* search for a constant op that could let us fold the test */
4991 if ((cstop = search_const(first))) {
4992 if (cstop->op_private & OPpCONST_STRICT)
4993 no_bareword_allowed(cstop);
4994 else if ((cstop->op_private & OPpCONST_BARE))
4995 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4996 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4997 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4998 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5000 if (other->op_type == OP_CONST)
5001 other->op_private |= OPpCONST_SHORTCIRCUIT;
5003 OP *newop = newUNOP(OP_NULL, 0, other);
5004 op_getmad(first, newop, '1');
5005 newop->op_targ = type; /* set "was" field */
5009 if (other->op_type == OP_LEAVE)
5010 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5011 else if (other->op_type == OP_MATCH
5012 || other->op_type == OP_SUBST
5013 || other->op_type == OP_TRANSR
5014 || other->op_type == OP_TRANS)
5015 /* Mark the op as being unbindable with =~ */
5016 other->op_flags |= OPf_SPECIAL;
5020 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5021 const OP *o2 = other;
5022 if ( ! (o2->op_type == OP_LIST
5023 && (( o2 = cUNOPx(o2)->op_first))
5024 && o2->op_type == OP_PUSHMARK
5025 && (( o2 = o2->op_sibling)) )
5028 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5029 || o2->op_type == OP_PADHV)
5030 && o2->op_private & OPpLVAL_INTRO
5031 && !(o2->op_private & OPpPAD_STATE))
5033 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5034 "Deprecated use of my() in false conditional");
5038 if (first->op_type == OP_CONST)
5039 first->op_private |= OPpCONST_SHORTCIRCUIT;
5041 first = newUNOP(OP_NULL, 0, first);
5042 op_getmad(other, first, '2');
5043 first->op_targ = type; /* set "was" field */
5050 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5051 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5053 const OP * const k1 = ((UNOP*)first)->op_first;
5054 const OP * const k2 = k1->op_sibling;
5056 switch (first->op_type)
5059 if (k2 && k2->op_type == OP_READLINE
5060 && (k2->op_flags & OPf_STACKED)
5061 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5063 warnop = k2->op_type;
5068 if (k1->op_type == OP_READDIR
5069 || k1->op_type == OP_GLOB
5070 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5071 || k1->op_type == OP_EACH)
5073 warnop = ((k1->op_type == OP_NULL)
5074 ? (OPCODE)k1->op_targ : k1->op_type);
5079 const line_t oldline = CopLINE(PL_curcop);
5080 CopLINE_set(PL_curcop, PL_parser->copline);
5081 Perl_warner(aTHX_ packWARN(WARN_MISC),
5082 "Value of %s%s can be \"0\"; test with defined()",
5084 ((warnop == OP_READLINE || warnop == OP_GLOB)
5085 ? " construct" : "() operator"));
5086 CopLINE_set(PL_curcop, oldline);
5093 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5094 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5096 NewOp(1101, logop, 1, LOGOP);
5098 logop->op_type = (OPCODE)type;
5099 logop->op_ppaddr = PL_ppaddr[type];
5100 logop->op_first = first;
5101 logop->op_flags = (U8)(flags | OPf_KIDS);
5102 logop->op_other = LINKLIST(other);
5103 logop->op_private = (U8)(1 | (flags >> 8));
5105 /* establish postfix order */
5106 logop->op_next = LINKLIST(first);
5107 first->op_next = (OP*)logop;
5108 first->op_sibling = other;
5110 CHECKOP(type,logop);
5112 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5119 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5121 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5122 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5123 will be set automatically, and, shifted up eight bits, the eight bits of
5124 C<op_private>, except that the bit with value 1 is automatically set.
5125 I<first> supplies the expression selecting between the two branches,
5126 and I<trueop> and I<falseop> supply the branches; they are consumed by
5127 this function and become part of the constructed op tree.
5133 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5141 PERL_ARGS_ASSERT_NEWCONDOP;
5144 return newLOGOP(OP_AND, 0, first, trueop);
5146 return newLOGOP(OP_OR, 0, first, falseop);
5148 scalarboolean(first);
5149 if ((cstop = search_const(first))) {
5150 /* Left or right arm of the conditional? */
5151 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5152 OP *live = left ? trueop : falseop;
5153 OP *const dead = left ? falseop : trueop;
5154 if (cstop->op_private & OPpCONST_BARE &&
5155 cstop->op_private & OPpCONST_STRICT) {
5156 no_bareword_allowed(cstop);
5159 /* This is all dead code when PERL_MAD is not defined. */
5160 live = newUNOP(OP_NULL, 0, live);
5161 op_getmad(first, live, 'C');
5162 op_getmad(dead, live, left ? 'e' : 't');
5167 if (live->op_type == OP_LEAVE)
5168 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5169 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5170 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5171 /* Mark the op as being unbindable with =~ */
5172 live->op_flags |= OPf_SPECIAL;
5175 NewOp(1101, logop, 1, LOGOP);
5176 logop->op_type = OP_COND_EXPR;
5177 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5178 logop->op_first = first;
5179 logop->op_flags = (U8)(flags | OPf_KIDS);
5180 logop->op_private = (U8)(1 | (flags >> 8));
5181 logop->op_other = LINKLIST(trueop);
5182 logop->op_next = LINKLIST(falseop);
5184 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5187 /* establish postfix order */
5188 start = LINKLIST(first);
5189 first->op_next = (OP*)logop;
5191 first->op_sibling = trueop;
5192 trueop->op_sibling = falseop;
5193 o = newUNOP(OP_NULL, 0, (OP*)logop);
5195 trueop->op_next = falseop->op_next = o;
5202 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5204 Constructs and returns a C<range> op, with subordinate C<flip> and
5205 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5206 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5207 for both the C<flip> and C<range> ops, except that the bit with value
5208 1 is automatically set. I<left> and I<right> supply the expressions
5209 controlling the endpoints of the range; they are consumed by this function
5210 and become part of the constructed op tree.
5216 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5225 PERL_ARGS_ASSERT_NEWRANGE;
5227 NewOp(1101, range, 1, LOGOP);
5229 range->op_type = OP_RANGE;
5230 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5231 range->op_first = left;
5232 range->op_flags = OPf_KIDS;
5233 leftstart = LINKLIST(left);
5234 range->op_other = LINKLIST(right);
5235 range->op_private = (U8)(1 | (flags >> 8));
5237 left->op_sibling = right;
5239 range->op_next = (OP*)range;
5240 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5241 flop = newUNOP(OP_FLOP, 0, flip);
5242 o = newUNOP(OP_NULL, 0, flop);
5244 range->op_next = leftstart;
5246 left->op_next = flip;
5247 right->op_next = flop;
5249 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5250 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5251 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5252 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5254 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5255 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5258 if (!flip->op_private || !flop->op_private)
5259 LINKLIST(o); /* blow off optimizer unless constant */
5265 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5267 Constructs, checks, and returns an op tree expressing a loop. This is
5268 only a loop in the control flow through the op tree; it does not have
5269 the heavyweight loop structure that allows exiting the loop by C<last>
5270 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5271 top-level op, except that some bits will be set automatically as required.
5272 I<expr> supplies the expression controlling loop iteration, and I<block>
5273 supplies the body of the loop; they are consumed by this function and
5274 become part of the constructed op tree. I<debuggable> is currently
5275 unused and should always be 1.
5281 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5286 const bool once = block && block->op_flags & OPf_SPECIAL &&
5287 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5289 PERL_UNUSED_ARG(debuggable);
5292 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5293 return block; /* do {} while 0 does once */
5294 if (expr->op_type == OP_READLINE
5295 || expr->op_type == OP_READDIR
5296 || expr->op_type == OP_GLOB
5297 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5298 expr = newUNOP(OP_DEFINED, 0,
5299 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5300 } else if (expr->op_flags & OPf_KIDS) {
5301 const OP * const k1 = ((UNOP*)expr)->op_first;
5302 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5303 switch (expr->op_type) {
5305 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5306 && (k2->op_flags & OPf_STACKED)
5307 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5308 expr = newUNOP(OP_DEFINED, 0, expr);
5312 if (k1 && (k1->op_type == OP_READDIR
5313 || k1->op_type == OP_GLOB
5314 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5315 || k1->op_type == OP_EACH))
5316 expr = newUNOP(OP_DEFINED, 0, expr);
5322 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5323 * op, in listop. This is wrong. [perl #27024] */
5325 block = newOP(OP_NULL, 0);
5326 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5327 o = new_logop(OP_AND, 0, &expr, &listop);
5330 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5332 if (once && o != listop)
5333 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5336 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5338 o->op_flags |= flags;
5340 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5345 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5347 Constructs, checks, and returns an op tree expressing a C<while> loop.
5348 This is a heavyweight loop, with structure that allows exiting the loop
5349 by C<last> and suchlike.
5351 I<loop> is an optional preconstructed C<enterloop> op to use in the
5352 loop; if it is null then a suitable op will be constructed automatically.
5353 I<expr> supplies the loop's controlling expression. I<block> supplies the
5354 main body of the loop, and I<cont> optionally supplies a C<continue> block
5355 that operates as a second half of the body. All of these optree inputs
5356 are consumed by this function and become part of the constructed op tree.
5358 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5359 op and, shifted up eight bits, the eight bits of C<op_private> for
5360 the C<leaveloop> op, except that (in both cases) some bits will be set
5361 automatically. I<debuggable> is currently unused and should always be 1.
5362 I<has_my> can be supplied as true to force the
5363 loop body to be enclosed in its own scope.
5369 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5370 OP *expr, OP *block, OP *cont, I32 has_my)
5379 PERL_UNUSED_ARG(debuggable);
5382 if (expr->op_type == OP_READLINE
5383 || expr->op_type == OP_READDIR
5384 || expr->op_type == OP_GLOB
5385 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5386 expr = newUNOP(OP_DEFINED, 0,
5387 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5388 } else if (expr->op_flags & OPf_KIDS) {
5389 const OP * const k1 = ((UNOP*)expr)->op_first;
5390 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5391 switch (expr->op_type) {
5393 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5394 && (k2->op_flags & OPf_STACKED)
5395 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5396 expr = newUNOP(OP_DEFINED, 0, expr);
5400 if (k1 && (k1->op_type == OP_READDIR
5401 || k1->op_type == OP_GLOB
5402 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5403 || k1->op_type == OP_EACH))
5404 expr = newUNOP(OP_DEFINED, 0, expr);
5411 block = newOP(OP_NULL, 0);
5412 else if (cont || has_my) {
5413 block = op_scope(block);
5417 next = LINKLIST(cont);
5420 OP * const unstack = newOP(OP_UNSTACK, 0);
5423 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5427 listop = op_append_list(OP_LINESEQ, block, cont);
5429 redo = LINKLIST(listop);
5433 o = new_logop(OP_AND, 0, &expr, &listop);
5434 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5435 op_free(expr); /* oops, it's a while (0) */
5437 return NULL; /* listop already freed by new_logop */
5440 ((LISTOP*)listop)->op_last->op_next =
5441 (o == listop ? redo : LINKLIST(o));
5447 NewOp(1101,loop,1,LOOP);
5448 loop->op_type = OP_ENTERLOOP;
5449 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5450 loop->op_private = 0;
5451 loop->op_next = (OP*)loop;
5454 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5456 loop->op_redoop = redo;
5457 loop->op_lastop = o;
5458 o->op_private |= loopflags;
5461 loop->op_nextop = next;
5463 loop->op_nextop = o;
5465 o->op_flags |= flags;
5466 o->op_private |= (flags >> 8);
5471 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5473 Constructs, checks, and returns an op tree expressing a C<foreach>
5474 loop (iteration through a list of values). This is a heavyweight loop,
5475 with structure that allows exiting the loop by C<last> and suchlike.
5477 I<sv> optionally supplies the variable that will be aliased to each
5478 item in turn; if null, it defaults to C<$_> (either lexical or global).
5479 I<expr> supplies the list of values to iterate over. I<block> supplies
5480 the main body of the loop, and I<cont> optionally supplies a C<continue>
5481 block that operates as a second half of the body. All of these optree
5482 inputs are consumed by this function and become part of the constructed
5485 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5486 op and, shifted up eight bits, the eight bits of C<op_private> for
5487 the C<leaveloop> op, except that (in both cases) some bits will be set
5494 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5499 PADOFFSET padoff = 0;
5504 PERL_ARGS_ASSERT_NEWFOROP;
5507 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5508 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5509 sv->op_type = OP_RV2GV;
5510 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5512 /* The op_type check is needed to prevent a possible segfault
5513 * if the loop variable is undeclared and 'strict vars' is in
5514 * effect. This is illegal but is nonetheless parsed, so we
5515 * may reach this point with an OP_CONST where we're expecting
5518 if (cUNOPx(sv)->op_first->op_type == OP_GV
5519 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5520 iterpflags |= OPpITER_DEF;
5522 else if (sv->op_type == OP_PADSV) { /* private variable */
5523 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5524 padoff = sv->op_targ;
5534 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5536 SV *const namesv = PAD_COMPNAME_SV(padoff);
5538 const char *const name = SvPV_const(namesv, len);
5540 if (len == 2 && name[0] == '$' && name[1] == '_')
5541 iterpflags |= OPpITER_DEF;
5545 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5546 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5547 sv = newGVOP(OP_GV, 0, PL_defgv);
5552 iterpflags |= OPpITER_DEF;
5554 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5555 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5556 iterflags |= OPf_STACKED;
5558 else if (expr->op_type == OP_NULL &&
5559 (expr->op_flags & OPf_KIDS) &&
5560 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5562 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5563 * set the STACKED flag to indicate that these values are to be
5564 * treated as min/max values by 'pp_iterinit'.
5566 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5567 LOGOP* const range = (LOGOP*) flip->op_first;
5568 OP* const left = range->op_first;
5569 OP* const right = left->op_sibling;
5572 range->op_flags &= ~OPf_KIDS;
5573 range->op_first = NULL;
5575 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5576 listop->op_first->op_next = range->op_next;
5577 left->op_next = range->op_other;
5578 right->op_next = (OP*)listop;
5579 listop->op_next = listop->op_first;
5582 op_getmad(expr,(OP*)listop,'O');
5586 expr = (OP*)(listop);
5588 iterflags |= OPf_STACKED;
5591 expr = op_lvalue(force_list(expr), OP_GREPSTART);
5594 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5595 op_append_elem(OP_LIST, expr, scalar(sv))));
5596 assert(!loop->op_next);
5597 /* for my $x () sets OPpLVAL_INTRO;
5598 * for our $x () sets OPpOUR_INTRO */
5599 loop->op_private = (U8)iterpflags;
5600 #ifdef PL_OP_SLAB_ALLOC
5603 NewOp(1234,tmp,1,LOOP);
5604 Copy(loop,tmp,1,LISTOP);
5605 S_op_destroy(aTHX_ (OP*)loop);
5609 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5611 loop->op_targ = padoff;
5612 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5614 op_getmad(madsv, (OP*)loop, 'v');
5619 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5621 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5622 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5623 determining the target of the op; it is consumed by this function and
5624 become part of the constructed op tree.
5630 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5635 PERL_ARGS_ASSERT_NEWLOOPEX;
5637 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5639 if (type != OP_GOTO || label->op_type == OP_CONST) {
5640 /* "last()" means "last" */
5641 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5642 o = newOP(type, OPf_SPECIAL);
5644 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5645 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5649 op_getmad(label,o,'L');
5655 /* Check whether it's going to be a goto &function */
5656 if (label->op_type == OP_ENTERSUB
5657 && !(label->op_flags & OPf_STACKED))
5658 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
5659 o = newUNOP(type, OPf_STACKED, label);
5661 PL_hints |= HINT_BLOCK_SCOPE;
5665 /* if the condition is a literal array or hash
5666 (or @{ ... } etc), make a reference to it.
5669 S_ref_array_or_hash(pTHX_ OP *cond)
5672 && (cond->op_type == OP_RV2AV
5673 || cond->op_type == OP_PADAV
5674 || cond->op_type == OP_RV2HV
5675 || cond->op_type == OP_PADHV))
5677 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
5680 && (cond->op_type == OP_ASLICE
5681 || cond->op_type == OP_HSLICE)) {
5683 /* anonlist now needs a list from this op, was previously used in
5685 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5686 cond->op_flags |= OPf_WANT_LIST;
5688 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
5695 /* These construct the optree fragments representing given()
5698 entergiven and enterwhen are LOGOPs; the op_other pointer
5699 points up to the associated leave op. We need this so we
5700 can put it in the context and make break/continue work.
5701 (Also, of course, pp_enterwhen will jump straight to
5702 op_other if the match fails.)
5706 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5707 I32 enter_opcode, I32 leave_opcode,
5708 PADOFFSET entertarg)
5714 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5716 NewOp(1101, enterop, 1, LOGOP);
5717 enterop->op_type = (Optype)enter_opcode;
5718 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5719 enterop->op_flags = (U8) OPf_KIDS;
5720 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5721 enterop->op_private = 0;
5723 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5726 enterop->op_first = scalar(cond);
5727 cond->op_sibling = block;
5729 o->op_next = LINKLIST(cond);
5730 cond->op_next = (OP *) enterop;
5733 /* This is a default {} block */
5734 enterop->op_first = block;
5735 enterop->op_flags |= OPf_SPECIAL;
5737 o->op_next = (OP *) enterop;
5740 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5741 entergiven and enterwhen both
5744 enterop->op_next = LINKLIST(block);
5745 block->op_next = enterop->op_other = o;
5750 /* Does this look like a boolean operation? For these purposes
5751 a boolean operation is:
5752 - a subroutine call [*]
5753 - a logical connective
5754 - a comparison operator
5755 - a filetest operator, with the exception of -s -M -A -C
5756 - defined(), exists() or eof()
5757 - /$re/ or $foo =~ /$re/
5759 [*] possibly surprising
5762 S_looks_like_bool(pTHX_ const OP *o)
5766 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5768 switch(o->op_type) {
5771 return looks_like_bool(cLOGOPo->op_first);
5775 looks_like_bool(cLOGOPo->op_first)
5776 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5781 o->op_flags & OPf_KIDS
5782 && looks_like_bool(cUNOPo->op_first));
5786 case OP_NOT: case OP_XOR:
5788 case OP_EQ: case OP_NE: case OP_LT:
5789 case OP_GT: case OP_LE: case OP_GE:
5791 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5792 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5794 case OP_SEQ: case OP_SNE: case OP_SLT:
5795 case OP_SGT: case OP_SLE: case OP_SGE:
5799 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5800 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5801 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5802 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5803 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5804 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5805 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5806 case OP_FTTEXT: case OP_FTBINARY:
5808 case OP_DEFINED: case OP_EXISTS:
5809 case OP_MATCH: case OP_EOF:
5816 /* Detect comparisons that have been optimized away */
5817 if (cSVOPo->op_sv == &PL_sv_yes
5818 || cSVOPo->op_sv == &PL_sv_no)
5831 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5833 Constructs, checks, and returns an op tree expressing a C<given> block.
5834 I<cond> supplies the expression that will be locally assigned to a lexical
5835 variable, and I<block> supplies the body of the C<given> construct; they
5836 are consumed by this function and become part of the constructed op tree.
5837 I<defsv_off> is the pad offset of the scalar lexical variable that will
5844 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5847 PERL_ARGS_ASSERT_NEWGIVENOP;
5848 return newGIVWHENOP(
5849 ref_array_or_hash(cond),
5851 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5856 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5858 Constructs, checks, and returns an op tree expressing a C<when> block.
5859 I<cond> supplies the test expression, and I<block> supplies the block
5860 that will be executed if the test evaluates to true; they are consumed
5861 by this function and become part of the constructed op tree. I<cond>
5862 will be interpreted DWIMically, often as a comparison against C<$_>,
5863 and may be null to generate a C<default> block.
5869 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5871 const bool cond_llb = (!cond || looks_like_bool(cond));
5874 PERL_ARGS_ASSERT_NEWWHENOP;
5879 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5881 scalar(ref_array_or_hash(cond)));
5884 return newGIVWHENOP(
5886 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5887 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5891 =head1 Embedding Functions
5893 =for apidoc cv_undef
5895 Clear out all the active components of a CV. This can happen either
5896 by an explicit C<undef &foo>, or by the reference count going to zero.
5897 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5898 children can still follow the full lexical scope chain.
5904 Perl_cv_undef(pTHX_ CV *cv)
5908 PERL_ARGS_ASSERT_CV_UNDEF;
5910 DEBUG_X(PerlIO_printf(Perl_debug_log,
5911 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5912 PTR2UV(cv), PTR2UV(PL_comppad))
5916 if (CvFILE(cv) && !CvISXSUB(cv)) {
5917 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5918 Safefree(CvFILE(cv));
5923 if (!CvISXSUB(cv) && CvROOT(cv)) {
5924 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5925 Perl_croak(aTHX_ "Can't undef active subroutine");
5928 PAD_SAVE_SETNULLPAD();
5930 op_free(CvROOT(cv));
5935 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5940 /* remove CvOUTSIDE unless this is an undef rather than a free */
5941 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5942 if (!CvWEAKOUTSIDE(cv))
5943 SvREFCNT_dec(CvOUTSIDE(cv));
5944 CvOUTSIDE(cv) = NULL;
5947 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5950 if (CvISXSUB(cv) && CvXSUB(cv)) {
5953 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5954 * ref status of CvOUTSIDE and CvGV */
5955 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5959 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5962 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5964 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5965 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5966 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5967 || (p && (len != SvCUR(cv) /* Not the same length. */
5968 || memNE(p, SvPVX_const(cv), len))))
5969 && ckWARN_d(WARN_PROTOTYPE)) {
5970 SV* const msg = sv_newmortal();
5974 gv_efullname3(name = sv_newmortal(), gv, NULL);
5975 sv_setpvs(msg, "Prototype mismatch:");
5977 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5979 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5981 sv_catpvs(msg, ": none");
5982 sv_catpvs(msg, " vs ");
5984 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5986 sv_catpvs(msg, "none");
5987 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5991 static void const_sv_xsub(pTHX_ CV* cv);
5995 =head1 Optree Manipulation Functions
5997 =for apidoc cv_const_sv
5999 If C<cv> is a constant sub eligible for inlining. returns the constant
6000 value returned by the sub. Otherwise, returns NULL.
6002 Constant subs can be created with C<newCONSTSUB> or as described in
6003 L<perlsub/"Constant Functions">.
6008 Perl_cv_const_sv(pTHX_ const CV *const cv)
6010 PERL_UNUSED_CONTEXT;
6013 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6015 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6018 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6019 * Can be called in 3 ways:
6022 * look for a single OP_CONST with attached value: return the value
6024 * cv && CvCLONE(cv) && !CvCONST(cv)
6026 * examine the clone prototype, and if contains only a single
6027 * OP_CONST referencing a pad const, or a single PADSV referencing
6028 * an outer lexical, return a non-zero value to indicate the CV is
6029 * a candidate for "constizing" at clone time
6033 * We have just cloned an anon prototype that was marked as a const
6034 * candidiate. Try to grab the current value, and in the case of
6035 * PADSV, ignore it if it has multiple references. Return the value.
6039 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6050 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6051 o = cLISTOPo->op_first->op_sibling;
6053 for (; o; o = o->op_next) {
6054 const OPCODE type = o->op_type;
6056 if (sv && o->op_next == o)
6058 if (o->op_next != o) {
6059 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6061 if (type == OP_DBSTATE)
6064 if (type == OP_LEAVESUB || type == OP_RETURN)
6068 if (type == OP_CONST && cSVOPo->op_sv)
6070 else if (cv && type == OP_CONST) {
6071 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6075 else if (cv && type == OP_PADSV) {
6076 if (CvCONST(cv)) { /* newly cloned anon */
6077 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6078 /* the candidate should have 1 ref from this pad and 1 ref
6079 * from the parent */
6080 if (!sv || SvREFCNT(sv) != 2)
6087 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6088 sv = &PL_sv_undef; /* an arbitrary non-null value */
6103 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6106 /* This would be the return value, but the return cannot be reached. */
6107 OP* pegop = newOP(OP_NULL, 0);
6110 PERL_UNUSED_ARG(floor);
6120 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6122 NORETURN_FUNCTION_END;
6127 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6129 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6133 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6138 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6139 register CV *cv = NULL;
6141 /* If the subroutine has no body, no attributes, and no builtin attributes
6142 then it's just a sub declaration, and we may be able to get away with
6143 storing with a placeholder scalar in the symbol table, rather than a
6144 full GV and CV. If anything is present then it will take a full CV to
6146 const I32 gv_fetch_flags
6147 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6149 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6150 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6154 assert(proto->op_type == OP_CONST);
6155 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6161 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6163 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6164 SV * const sv = sv_newmortal();
6165 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6166 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6167 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6168 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6170 } else if (PL_curstash) {
6171 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6174 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6178 if (!PL_madskills) {
6187 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6188 maximum a prototype before. */
6189 if (SvTYPE(gv) > SVt_NULL) {
6190 if (!SvPOK((const SV *)gv)
6191 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6193 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6195 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6198 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6200 sv_setiv(MUTABLE_SV(gv), -1);
6202 SvREFCNT_dec(PL_compcv);
6203 cv = PL_compcv = NULL;
6207 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6209 if (!block || !ps || *ps || attrs
6210 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6212 || block->op_type == OP_NULL
6217 const_sv = op_const_sv(block, NULL);
6220 const bool exists = CvROOT(cv) || CvXSUB(cv);
6222 /* if the subroutine doesn't exist and wasn't pre-declared
6223 * with a prototype, assume it will be AUTOLOADed,
6224 * skipping the prototype check
6226 if (exists || SvPOK(cv))
6227 cv_ckproto_len(cv, gv, ps, ps_len);
6228 /* already defined (or promised)? */
6229 if (exists || GvASSUMECV(gv)) {
6232 || block->op_type == OP_NULL
6235 if (CvFLAGS(PL_compcv)) {
6236 /* might have had built-in attrs applied */
6237 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6238 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6239 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6241 /* just a "sub foo;" when &foo is already defined */
6242 SAVEFREESV(PL_compcv);
6247 && block->op_type != OP_NULL
6250 if (ckWARN(WARN_REDEFINE)
6252 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6254 const line_t oldline = CopLINE(PL_curcop);
6255 if (PL_parser && PL_parser->copline != NOLINE)
6256 CopLINE_set(PL_curcop, PL_parser->copline);
6257 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6258 CvCONST(cv) ? "Constant subroutine %s redefined"
6259 : "Subroutine %s redefined", name);
6260 CopLINE_set(PL_curcop, oldline);
6263 if (!PL_minus_c) /* keep old one around for madskills */
6266 /* (PL_madskills unset in used file.) */
6274 SvREFCNT_inc_simple_void_NN(const_sv);
6276 assert(!CvROOT(cv) && !CvCONST(cv));
6277 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6278 CvXSUBANY(cv).any_ptr = const_sv;
6279 CvXSUB(cv) = const_sv_xsub;
6285 cv = newCONSTSUB(NULL, name, const_sv);
6287 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6288 (CvGV(cv) && GvSTASH(CvGV(cv)))
6297 SvREFCNT_dec(PL_compcv);
6301 if (cv) { /* must reuse cv if autoloaded */
6302 /* transfer PL_compcv to cv */
6305 && block->op_type != OP_NULL
6308 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6310 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6311 if (!CvWEAKOUTSIDE(cv))
6312 SvREFCNT_dec(CvOUTSIDE(cv));
6313 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6314 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6315 CvOUTSIDE(PL_compcv) = 0;
6316 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6317 CvPADLIST(PL_compcv) = 0;
6318 /* inner references to PL_compcv must be fixed up ... */
6319 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6320 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6321 ++PL_sub_generation;
6324 /* Might have had built-in attributes applied -- propagate them. */
6325 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6327 /* ... before we throw it away */
6328 SvREFCNT_dec(PL_compcv);
6336 if (strEQ(name, "import")) {
6337 PL_formfeed = MUTABLE_SV(cv);
6338 /* diag_listed_as: SKIPME */
6339 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6343 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6348 CvFILE_set_from_cop(cv, PL_curcop);
6349 CvSTASH_set(cv, PL_curstash);
6352 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6353 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6354 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6358 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6360 if (PL_parser && PL_parser->error_count) {
6364 const char *s = strrchr(name, ':');
6366 if (strEQ(s, "BEGIN")) {
6367 const char not_safe[] =
6368 "BEGIN not safe after errors--compilation aborted";
6369 if (PL_in_eval & EVAL_KEEPERR)
6370 Perl_croak(aTHX_ not_safe);
6372 /* force display of errors found but not reported */
6373 sv_catpv(ERRSV, not_safe);
6374 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6383 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6384 the debugger could be able to set a breakpoint in, so signal to
6385 pp_entereval that it should not throw away any saved lines at scope
6388 PL_breakable_sub_gen++;
6390 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6391 op_lvalue(scalarseq(block), OP_LEAVESUBLV));
6392 block->op_attached = 1;
6395 /* This makes sub {}; work as expected. */
6396 if (block->op_type == OP_STUB) {
6397 OP* const newblock = newSTATEOP(0, NULL, 0);
6399 op_getmad(block,newblock,'B');
6406 block->op_attached = 1;
6407 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6409 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6410 OpREFCNT_set(CvROOT(cv), 1);
6411 CvSTART(cv) = LINKLIST(CvROOT(cv));
6412 CvROOT(cv)->op_next = 0;
6413 CALL_PEEP(CvSTART(cv));
6415 /* now that optimizer has done its work, adjust pad values */
6417 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6420 assert(!CvCONST(cv));
6421 if (ps && !*ps && op_const_sv(block, cv))
6426 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6427 SV * const tmpstr = sv_newmortal();
6428 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6429 GV_ADDMULTI, SVt_PVHV);
6431 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6434 (long)CopLINE(PL_curcop));
6435 gv_efullname3(tmpstr, gv, NULL);
6436 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6437 SvCUR(tmpstr), sv, 0);
6438 hv = GvHVn(db_postponed);
6439 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6440 CV * const pcv = GvCV(db_postponed);
6446 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6451 if (name && ! (PL_parser && PL_parser->error_count))
6452 process_special_blocks(name, gv, cv);
6457 PL_parser->copline = NOLINE;
6463 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6466 const char *const colon = strrchr(fullname,':');
6467 const char *const name = colon ? colon + 1 : fullname;
6469 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6472 if (strEQ(name, "BEGIN")) {
6473 const I32 oldscope = PL_scopestack_ix;
6475 SAVECOPFILE(&PL_compiling);
6476 SAVECOPLINE(&PL_compiling);
6478 DEBUG_x( dump_sub(gv) );
6479 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6480 GvCV(gv) = 0; /* cv has been hijacked */
6481 call_list(oldscope, PL_beginav);
6483 PL_curcop = &PL_compiling;
6484 CopHINTS_set(&PL_compiling, PL_hints);
6491 if strEQ(name, "END") {
6492 DEBUG_x( dump_sub(gv) );
6493 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6496 } else if (*name == 'U') {
6497 if (strEQ(name, "UNITCHECK")) {
6498 /* It's never too late to run a unitcheck block */
6499 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6503 } else if (*name == 'C') {
6504 if (strEQ(name, "CHECK")) {
6506 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6507 "Too late to run CHECK block");
6508 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6512 } else if (*name == 'I') {
6513 if (strEQ(name, "INIT")) {
6515 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6516 "Too late to run INIT block");
6517 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6523 DEBUG_x( dump_sub(gv) );
6524 GvCV(gv) = 0; /* cv has been hijacked */
6529 =for apidoc newCONSTSUB
6531 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6532 eligible for inlining at compile-time.
6534 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6535 which won't be called if used as a destructor, but will suppress the overhead
6536 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6543 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6548 const char *const file = CopFILE(PL_curcop);
6550 SV *const temp_sv = CopFILESV(PL_curcop);
6551 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6556 if (IN_PERL_RUNTIME) {
6557 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6558 * an op shared between threads. Use a non-shared COP for our
6560 SAVEVPTR(PL_curcop);
6561 PL_curcop = &PL_compiling;
6563 SAVECOPLINE(PL_curcop);
6564 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6567 PL_hints &= ~HINT_BLOCK_SCOPE;
6570 SAVESPTR(PL_curstash);
6571 SAVECOPSTASH(PL_curcop);
6572 PL_curstash = stash;
6573 CopSTASH_set(PL_curcop,stash);
6576 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6577 and so doesn't get free()d. (It's expected to be from the C pre-
6578 processor __FILE__ directive). But we need a dynamically allocated one,
6579 and we need it to get freed. */
6580 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6581 XS_DYNAMIC_FILENAME);
6582 CvXSUBANY(cv).any_ptr = sv;
6587 CopSTASH_free(PL_curcop);
6595 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6596 const char *const filename, const char *const proto,
6599 CV *cv = newXS(name, subaddr, filename);
6601 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6603 if (flags & XS_DYNAMIC_FILENAME) {
6604 /* We need to "make arrangements" (ie cheat) to ensure that the
6605 filename lasts as long as the PVCV we just created, but also doesn't
6607 STRLEN filename_len = strlen(filename);
6608 STRLEN proto_and_file_len = filename_len;
6609 char *proto_and_file;
6613 proto_len = strlen(proto);
6614 proto_and_file_len += proto_len;
6616 Newx(proto_and_file, proto_and_file_len + 1, char);
6617 Copy(proto, proto_and_file, proto_len, char);
6618 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6621 proto_and_file = savepvn(filename, filename_len);
6624 /* This gets free()d. :-) */
6625 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6626 SV_HAS_TRAILING_NUL);
6628 /* This gives us the correct prototype, rather than one with the
6629 file name appended. */
6630 SvCUR_set(cv, proto_len);
6634 CvFILE(cv) = proto_and_file + proto_len;
6636 sv_setpv(MUTABLE_SV(cv), proto);
6642 =for apidoc U||newXS
6644 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6645 static storage, as it is used directly as CvFILE(), without a copy being made.
6651 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6654 GV * const gv = gv_fetchpv(name ? name :
6655 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6656 GV_ADDMULTI, SVt_PVCV);
6659 PERL_ARGS_ASSERT_NEWXS;
6662 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6664 if ((cv = (name ? GvCV(gv) : NULL))) {
6666 /* just a cached method */
6670 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6671 /* already defined (or promised) */
6672 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6673 if (ckWARN(WARN_REDEFINE)) {
6674 GV * const gvcv = CvGV(cv);
6676 HV * const stash = GvSTASH(gvcv);
6678 const char *redefined_name = HvNAME_get(stash);
6679 if ( strEQ(redefined_name,"autouse") ) {
6680 const line_t oldline = CopLINE(PL_curcop);
6681 if (PL_parser && PL_parser->copline != NOLINE)
6682 CopLINE_set(PL_curcop, PL_parser->copline);
6683 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6684 CvCONST(cv) ? "Constant subroutine %s redefined"
6685 : "Subroutine %s redefined"
6687 CopLINE_set(PL_curcop, oldline);
6697 if (cv) /* must reuse cv if autoloaded */
6700 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6704 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6710 (void)gv_fetchfile(filename);
6711 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6712 an external constant string */
6714 CvXSUB(cv) = subaddr;
6717 process_special_blocks(name, gv, cv);
6727 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6732 OP* pegop = newOP(OP_NULL, 0);
6736 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6737 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6740 if ((cv = GvFORM(gv))) {
6741 if (ckWARN(WARN_REDEFINE)) {
6742 const line_t oldline = CopLINE(PL_curcop);
6743 if (PL_parser && PL_parser->copline != NOLINE)
6744 CopLINE_set(PL_curcop, PL_parser->copline);
6746 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6747 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6749 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6750 "Format STDOUT redefined");
6752 CopLINE_set(PL_curcop, oldline);
6759 CvFILE_set_from_cop(cv, PL_curcop);
6762 pad_tidy(padtidy_FORMAT);
6763 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6764 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6765 OpREFCNT_set(CvROOT(cv), 1);
6766 CvSTART(cv) = LINKLIST(CvROOT(cv));
6767 CvROOT(cv)->op_next = 0;
6768 CALL_PEEP(CvSTART(cv));
6770 op_getmad(o,pegop,'n');
6771 op_getmad_weak(block, pegop, 'b');
6776 PL_parser->copline = NOLINE;
6784 Perl_newANONLIST(pTHX_ OP *o)
6786 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6790 Perl_newANONHASH(pTHX_ OP *o)
6792 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6796 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6798 return newANONATTRSUB(floor, proto, NULL, block);
6802 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6804 return newUNOP(OP_REFGEN, 0,
6805 newSVOP(OP_ANONCODE, 0,
6806 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6810 Perl_oopsAV(pTHX_ OP *o)
6814 PERL_ARGS_ASSERT_OOPSAV;
6816 switch (o->op_type) {
6818 o->op_type = OP_PADAV;
6819 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6820 return ref(o, OP_RV2AV);
6823 o->op_type = OP_RV2AV;
6824 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6829 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6836 Perl_oopsHV(pTHX_ OP *o)
6840 PERL_ARGS_ASSERT_OOPSHV;
6842 switch (o->op_type) {
6845 o->op_type = OP_PADHV;
6846 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6847 return ref(o, OP_RV2HV);
6851 o->op_type = OP_RV2HV;
6852 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6857 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6864 Perl_newAVREF(pTHX_ OP *o)
6868 PERL_ARGS_ASSERT_NEWAVREF;
6870 if (o->op_type == OP_PADANY) {
6871 o->op_type = OP_PADAV;
6872 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6875 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6876 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6877 "Using an array as a reference is deprecated");
6879 return newUNOP(OP_RV2AV, 0, scalar(o));
6883 Perl_newGVREF(pTHX_ I32 type, OP *o)
6885 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6886 return newUNOP(OP_NULL, 0, o);
6887 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6891 Perl_newHVREF(pTHX_ OP *o)
6895 PERL_ARGS_ASSERT_NEWHVREF;
6897 if (o->op_type == OP_PADANY) {
6898 o->op_type = OP_PADHV;
6899 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6902 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6903 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6904 "Using a hash as a reference is deprecated");
6906 return newUNOP(OP_RV2HV, 0, scalar(o));
6910 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6912 return newUNOP(OP_RV2CV, flags, scalar(o));
6916 Perl_newSVREF(pTHX_ OP *o)
6920 PERL_ARGS_ASSERT_NEWSVREF;
6922 if (o->op_type == OP_PADANY) {
6923 o->op_type = OP_PADSV;
6924 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6927 return newUNOP(OP_RV2SV, 0, scalar(o));
6930 /* Check routines. See the comments at the top of this file for details
6931 * on when these are called */
6934 Perl_ck_anoncode(pTHX_ OP *o)
6936 PERL_ARGS_ASSERT_CK_ANONCODE;
6938 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6940 cSVOPo->op_sv = NULL;
6945 Perl_ck_bitop(pTHX_ OP *o)
6949 PERL_ARGS_ASSERT_CK_BITOP;
6951 #define OP_IS_NUMCOMPARE(op) \
6952 ((op) == OP_LT || (op) == OP_I_LT || \
6953 (op) == OP_GT || (op) == OP_I_GT || \
6954 (op) == OP_LE || (op) == OP_I_LE || \
6955 (op) == OP_GE || (op) == OP_I_GE || \
6956 (op) == OP_EQ || (op) == OP_I_EQ || \
6957 (op) == OP_NE || (op) == OP_I_NE || \
6958 (op) == OP_NCMP || (op) == OP_I_NCMP)
6959 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6960 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6961 && (o->op_type == OP_BIT_OR
6962 || o->op_type == OP_BIT_AND
6963 || o->op_type == OP_BIT_XOR))
6965 const OP * const left = cBINOPo->op_first;
6966 const OP * const right = left->op_sibling;
6967 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6968 (left->op_flags & OPf_PARENS) == 0) ||
6969 (OP_IS_NUMCOMPARE(right->op_type) &&
6970 (right->op_flags & OPf_PARENS) == 0))
6971 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6972 "Possible precedence problem on bitwise %c operator",
6973 o->op_type == OP_BIT_OR ? '|'
6974 : o->op_type == OP_BIT_AND ? '&' : '^'
6981 Perl_ck_concat(pTHX_ OP *o)
6983 const OP * const kid = cUNOPo->op_first;
6985 PERL_ARGS_ASSERT_CK_CONCAT;
6986 PERL_UNUSED_CONTEXT;
6988 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6989 !(kUNOP->op_first->op_flags & OPf_MOD))
6990 o->op_flags |= OPf_STACKED;
6995 Perl_ck_spair(pTHX_ OP *o)
6999 PERL_ARGS_ASSERT_CK_SPAIR;
7001 if (o->op_flags & OPf_KIDS) {
7004 const OPCODE type = o->op_type;
7005 o = modkids(ck_fun(o), type);
7006 kid = cUNOPo->op_first;
7007 newop = kUNOP->op_first->op_sibling;
7009 const OPCODE type = newop->op_type;
7010 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7011 type == OP_PADAV || type == OP_PADHV ||
7012 type == OP_RV2AV || type == OP_RV2HV)
7016 op_getmad(kUNOP->op_first,newop,'K');
7018 op_free(kUNOP->op_first);
7020 kUNOP->op_first = newop;
7022 o->op_ppaddr = PL_ppaddr[++o->op_type];
7027 Perl_ck_delete(pTHX_ OP *o)
7029 PERL_ARGS_ASSERT_CK_DELETE;
7033 if (o->op_flags & OPf_KIDS) {
7034 OP * const kid = cUNOPo->op_first;
7035 switch (kid->op_type) {
7037 o->op_flags |= OPf_SPECIAL;
7040 o->op_private |= OPpSLICE;
7043 o->op_flags |= OPf_SPECIAL;
7048 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7051 if (kid->op_private & OPpLVAL_INTRO)
7052 o->op_private |= OPpLVAL_INTRO;
7059 Perl_ck_die(pTHX_ OP *o)
7061 PERL_ARGS_ASSERT_CK_DIE;
7064 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7070 Perl_ck_eof(pTHX_ OP *o)
7074 PERL_ARGS_ASSERT_CK_EOF;
7076 if (o->op_flags & OPf_KIDS) {
7077 if (cLISTOPo->op_first->op_type == OP_STUB) {
7079 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7081 op_getmad(o,newop,'O');
7093 Perl_ck_eval(pTHX_ OP *o)
7097 PERL_ARGS_ASSERT_CK_EVAL;
7099 PL_hints |= HINT_BLOCK_SCOPE;
7100 if (o->op_flags & OPf_KIDS) {
7101 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7104 o->op_flags &= ~OPf_KIDS;
7107 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7113 cUNOPo->op_first = 0;
7118 NewOp(1101, enter, 1, LOGOP);
7119 enter->op_type = OP_ENTERTRY;
7120 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7121 enter->op_private = 0;
7123 /* establish postfix order */
7124 enter->op_next = (OP*)enter;
7126 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7127 o->op_type = OP_LEAVETRY;
7128 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7129 enter->op_other = o;
7130 op_getmad(oldo,o,'O');
7144 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7145 op_getmad(oldo,o,'O');
7147 o->op_targ = (PADOFFSET)PL_hints;
7148 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7149 /* Store a copy of %^H that pp_entereval can pick up. */
7150 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7151 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7152 cUNOPo->op_first->op_sibling = hhop;
7153 o->op_private |= OPpEVAL_HAS_HH;
7159 Perl_ck_exit(pTHX_ OP *o)
7161 PERL_ARGS_ASSERT_CK_EXIT;
7164 HV * const table = GvHV(PL_hintgv);
7166 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7167 if (svp && *svp && SvTRUE(*svp))
7168 o->op_private |= OPpEXIT_VMSISH;
7170 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7176 Perl_ck_exec(pTHX_ OP *o)
7178 PERL_ARGS_ASSERT_CK_EXEC;
7180 if (o->op_flags & OPf_STACKED) {
7183 kid = cUNOPo->op_first->op_sibling;
7184 if (kid->op_type == OP_RV2GV)
7193 Perl_ck_exists(pTHX_ OP *o)
7197 PERL_ARGS_ASSERT_CK_EXISTS;
7200 if (o->op_flags & OPf_KIDS) {
7201 OP * const kid = cUNOPo->op_first;
7202 if (kid->op_type == OP_ENTERSUB) {
7203 (void) ref(kid, o->op_type);
7204 if (kid->op_type != OP_RV2CV
7205 && !(PL_parser && PL_parser->error_count))
7206 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7208 o->op_private |= OPpEXISTS_SUB;
7210 else if (kid->op_type == OP_AELEM)
7211 o->op_flags |= OPf_SPECIAL;
7212 else if (kid->op_type != OP_HELEM)
7213 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7221 Perl_ck_rvconst(pTHX_ register OP *o)
7224 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7226 PERL_ARGS_ASSERT_CK_RVCONST;
7228 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7229 if (o->op_type == OP_RV2CV)
7230 o->op_private &= ~1;
7232 if (kid->op_type == OP_CONST) {
7235 SV * const kidsv = kid->op_sv;
7237 /* Is it a constant from cv_const_sv()? */
7238 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7239 SV * const rsv = SvRV(kidsv);
7240 const svtype type = SvTYPE(rsv);
7241 const char *badtype = NULL;
7243 switch (o->op_type) {
7245 if (type > SVt_PVMG)
7246 badtype = "a SCALAR";
7249 if (type != SVt_PVAV)
7250 badtype = "an ARRAY";
7253 if (type != SVt_PVHV)
7257 if (type != SVt_PVCV)
7262 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7265 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7266 const char *badthing;
7267 switch (o->op_type) {
7269 badthing = "a SCALAR";
7272 badthing = "an ARRAY";
7275 badthing = "a HASH";
7283 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7284 SVfARG(kidsv), badthing);
7287 * This is a little tricky. We only want to add the symbol if we
7288 * didn't add it in the lexer. Otherwise we get duplicate strict
7289 * warnings. But if we didn't add it in the lexer, we must at
7290 * least pretend like we wanted to add it even if it existed before,
7291 * or we get possible typo warnings. OPpCONST_ENTERED says
7292 * whether the lexer already added THIS instance of this symbol.
7294 iscv = (o->op_type == OP_RV2CV) * 2;
7296 gv = gv_fetchsv(kidsv,
7297 iscv | !(kid->op_private & OPpCONST_ENTERED),
7300 : o->op_type == OP_RV2SV
7302 : o->op_type == OP_RV2AV
7304 : o->op_type == OP_RV2HV
7307 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7309 kid->op_type = OP_GV;
7310 SvREFCNT_dec(kid->op_sv);
7312 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7313 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7314 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7316 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7318 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7320 kid->op_private = 0;
7321 kid->op_ppaddr = PL_ppaddr[OP_GV];
7322 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7330 Perl_ck_ftst(pTHX_ OP *o)
7333 const I32 type = o->op_type;
7335 PERL_ARGS_ASSERT_CK_FTST;
7337 if (o->op_flags & OPf_REF) {
7340 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7341 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7342 const OPCODE kidtype = kid->op_type;
7344 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7345 OP * const newop = newGVOP(type, OPf_REF,
7346 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7348 op_getmad(o,newop,'O');
7354 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7355 o->op_private |= OPpFT_ACCESS;
7356 if (PL_check[kidtype] == Perl_ck_ftst
7357 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7358 o->op_private |= OPpFT_STACKED;
7366 if (type == OP_FTTTY)
7367 o = newGVOP(type, OPf_REF, PL_stdingv);
7369 o = newUNOP(type, 0, newDEFSVOP());
7370 op_getmad(oldo,o,'O');
7376 Perl_ck_fun(pTHX_ OP *o)
7379 const int type = o->op_type;
7380 register I32 oa = PL_opargs[type] >> OASHIFT;
7382 PERL_ARGS_ASSERT_CK_FUN;
7384 if (o->op_flags & OPf_STACKED) {
7385 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7388 return no_fh_allowed(o);
7391 if (o->op_flags & OPf_KIDS) {
7392 OP **tokid = &cLISTOPo->op_first;
7393 register OP *kid = cLISTOPo->op_first;
7397 if (kid->op_type == OP_PUSHMARK ||
7398 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7400 tokid = &kid->op_sibling;
7401 kid = kid->op_sibling;
7403 if (!kid && PL_opargs[type] & OA_DEFGV)
7404 *tokid = kid = newDEFSVOP();
7408 sibl = kid->op_sibling;
7410 if (!sibl && kid->op_type == OP_STUB) {
7417 /* list seen where single (scalar) arg expected? */
7418 if (numargs == 1 && !(oa >> 4)
7419 && kid->op_type == OP_LIST && type != OP_SCALAR)
7421 return too_many_arguments(o,PL_op_desc[type]);
7434 if ((type == OP_PUSH || type == OP_UNSHIFT)
7435 && !kid->op_sibling)
7436 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7437 "Useless use of %s with no values",
7440 if (kid->op_type == OP_CONST &&
7441 (kid->op_private & OPpCONST_BARE))
7443 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7444 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7445 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7446 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7447 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7449 op_getmad(kid,newop,'K');
7454 kid->op_sibling = sibl;
7457 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7458 bad_type(numargs, "array", PL_op_desc[type], kid);
7459 op_lvalue(kid, type);
7462 if (kid->op_type == OP_CONST &&
7463 (kid->op_private & OPpCONST_BARE))
7465 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7466 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7467 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7468 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7469 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7471 op_getmad(kid,newop,'K');
7476 kid->op_sibling = sibl;
7479 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7480 bad_type(numargs, "hash", PL_op_desc[type], kid);
7481 op_lvalue(kid, type);
7485 OP * const newop = newUNOP(OP_NULL, 0, kid);
7486 kid->op_sibling = 0;
7488 newop->op_next = newop;
7490 kid->op_sibling = sibl;
7495 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7496 if (kid->op_type == OP_CONST &&
7497 (kid->op_private & OPpCONST_BARE))
7499 OP * const newop = newGVOP(OP_GV, 0,
7500 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7501 if (!(o->op_private & 1) && /* if not unop */
7502 kid == cLISTOPo->op_last)
7503 cLISTOPo->op_last = newop;
7505 op_getmad(kid,newop,'K');
7511 else if (kid->op_type == OP_READLINE) {
7512 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7513 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7516 I32 flags = OPf_SPECIAL;
7520 /* is this op a FH constructor? */
7521 if (is_handle_constructor(o,numargs)) {
7522 const char *name = NULL;
7526 /* Set a flag to tell rv2gv to vivify
7527 * need to "prove" flag does not mean something
7528 * else already - NI-S 1999/05/07
7531 if (kid->op_type == OP_PADSV) {
7533 = PAD_COMPNAME_SV(kid->op_targ);
7534 name = SvPV_const(namesv, len);
7536 else if (kid->op_type == OP_RV2SV
7537 && kUNOP->op_first->op_type == OP_GV)
7539 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7541 len = GvNAMELEN(gv);
7543 else if (kid->op_type == OP_AELEM
7544 || kid->op_type == OP_HELEM)
7547 OP *op = ((BINOP*)kid)->op_first;
7551 const char * const a =
7552 kid->op_type == OP_AELEM ?
7554 if (((op->op_type == OP_RV2AV) ||
7555 (op->op_type == OP_RV2HV)) &&
7556 (firstop = ((UNOP*)op)->op_first) &&
7557 (firstop->op_type == OP_GV)) {
7558 /* packagevar $a[] or $h{} */
7559 GV * const gv = cGVOPx_gv(firstop);
7567 else if (op->op_type == OP_PADAV
7568 || op->op_type == OP_PADHV) {
7569 /* lexicalvar $a[] or $h{} */
7570 const char * const padname =
7571 PAD_COMPNAME_PV(op->op_targ);
7580 name = SvPV_const(tmpstr, len);
7585 name = "__ANONIO__";
7588 op_lvalue(kid, type);
7592 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7593 namesv = PAD_SVl(targ);
7594 SvUPGRADE(namesv, SVt_PV);
7596 sv_setpvs(namesv, "$");
7597 sv_catpvn(namesv, name, len);
7600 kid->op_sibling = 0;
7601 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7602 kid->op_targ = targ;
7603 kid->op_private |= priv;
7605 kid->op_sibling = sibl;
7611 op_lvalue(scalar(kid), type);
7615 tokid = &kid->op_sibling;
7616 kid = kid->op_sibling;
7619 if (kid && kid->op_type != OP_STUB)
7620 return too_many_arguments(o,OP_DESC(o));
7621 o->op_private |= numargs;
7623 /* FIXME - should the numargs move as for the PERL_MAD case? */
7624 o->op_private |= numargs;
7626 return too_many_arguments(o,OP_DESC(o));
7630 else if (PL_opargs[type] & OA_DEFGV) {
7632 OP *newop = newUNOP(type, 0, newDEFSVOP());
7633 op_getmad(o,newop,'O');
7636 /* Ordering of these two is important to keep f_map.t passing. */
7638 return newUNOP(type, 0, newDEFSVOP());
7643 while (oa & OA_OPTIONAL)
7645 if (oa && oa != OA_LIST)
7646 return too_few_arguments(o,OP_DESC(o));
7652 Perl_ck_glob(pTHX_ OP *o)
7657 PERL_ARGS_ASSERT_CK_GLOB;
7660 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7661 op_append_elem(OP_GLOB, o, newDEFSVOP());
7663 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7664 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7666 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7669 #if !defined(PERL_EXTERNAL_GLOB)
7670 /* XXX this can be tightened up and made more failsafe. */
7671 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7674 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7675 newSVpvs("File::Glob"), NULL, NULL, NULL);
7676 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7677 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7678 GvCV(gv) = GvCV(glob_gv);
7679 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7680 GvIMPORTED_CV_on(gv);
7684 #endif /* PERL_EXTERNAL_GLOB */
7686 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7687 op_append_elem(OP_GLOB, o,
7688 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7689 o->op_type = OP_LIST;
7690 o->op_ppaddr = PL_ppaddr[OP_LIST];
7691 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7692 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7693 cLISTOPo->op_first->op_targ = 0;
7694 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7695 op_append_elem(OP_LIST, o,
7696 scalar(newUNOP(OP_RV2CV, 0,
7697 newGVOP(OP_GV, 0, gv)))));
7698 o = newUNOP(OP_NULL, 0, ck_subr(o));
7699 o->op_targ = OP_GLOB; /* hint at what it used to be */
7702 gv = newGVgen("main");
7704 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7710 Perl_ck_grep(pTHX_ OP *o)
7715 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7718 PERL_ARGS_ASSERT_CK_GREP;
7720 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7721 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7723 if (o->op_flags & OPf_STACKED) {
7726 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7727 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7728 return no_fh_allowed(o);
7729 for (k = kid; k; k = k->op_next) {
7732 NewOp(1101, gwop, 1, LOGOP);
7733 kid->op_next = (OP*)gwop;
7734 o->op_flags &= ~OPf_STACKED;
7736 kid = cLISTOPo->op_first->op_sibling;
7737 if (type == OP_MAPWHILE)
7742 if (PL_parser && PL_parser->error_count)
7744 kid = cLISTOPo->op_first->op_sibling;
7745 if (kid->op_type != OP_NULL)
7746 Perl_croak(aTHX_ "panic: ck_grep");
7747 kid = kUNOP->op_first;
7750 NewOp(1101, gwop, 1, LOGOP);
7751 gwop->op_type = type;
7752 gwop->op_ppaddr = PL_ppaddr[type];
7753 gwop->op_first = listkids(o);
7754 gwop->op_flags |= OPf_KIDS;
7755 gwop->op_other = LINKLIST(kid);
7756 kid->op_next = (OP*)gwop;
7757 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7758 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7759 o->op_private = gwop->op_private = 0;
7760 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7763 o->op_private = gwop->op_private = OPpGREP_LEX;
7764 gwop->op_targ = o->op_targ = offset;
7767 kid = cLISTOPo->op_first->op_sibling;
7768 if (!kid || !kid->op_sibling)
7769 return too_few_arguments(o,OP_DESC(o));
7770 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7771 op_lvalue(kid, OP_GREPSTART);
7777 Perl_ck_index(pTHX_ OP *o)
7779 PERL_ARGS_ASSERT_CK_INDEX;
7781 if (o->op_flags & OPf_KIDS) {
7782 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7784 kid = kid->op_sibling; /* get past "big" */
7785 if (kid && kid->op_type == OP_CONST)
7786 fbm_compile(((SVOP*)kid)->op_sv, 0);
7792 Perl_ck_lfun(pTHX_ OP *o)
7794 const OPCODE type = o->op_type;
7796 PERL_ARGS_ASSERT_CK_LFUN;
7798 return modkids(ck_fun(o), type);
7802 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7804 PERL_ARGS_ASSERT_CK_DEFINED;
7806 if ((o->op_flags & OPf_KIDS)) {
7807 switch (cUNOPo->op_first->op_type) {
7809 /* This is needed for
7810 if (defined %stash::)
7811 to work. Do not break Tk.
7813 break; /* Globals via GV can be undef */
7815 case OP_AASSIGN: /* Is this a good idea? */
7816 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7817 "defined(@array) is deprecated");
7818 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7819 "\t(Maybe you should just omit the defined()?)\n");
7823 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7824 "defined(%%hash) is deprecated");
7825 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7826 "\t(Maybe you should just omit the defined()?)\n");
7837 Perl_ck_readline(pTHX_ OP *o)
7839 PERL_ARGS_ASSERT_CK_READLINE;
7841 if (!(o->op_flags & OPf_KIDS)) {
7843 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7845 op_getmad(o,newop,'O');
7855 Perl_ck_rfun(pTHX_ OP *o)
7857 const OPCODE type = o->op_type;
7859 PERL_ARGS_ASSERT_CK_RFUN;
7861 return refkids(ck_fun(o), type);
7865 Perl_ck_listiob(pTHX_ OP *o)
7869 PERL_ARGS_ASSERT_CK_LISTIOB;
7871 kid = cLISTOPo->op_first;
7874 kid = cLISTOPo->op_first;
7876 if (kid->op_type == OP_PUSHMARK)
7877 kid = kid->op_sibling;
7878 if (kid && o->op_flags & OPf_STACKED)
7879 kid = kid->op_sibling;
7880 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7881 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7882 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7883 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7884 cLISTOPo->op_first->op_sibling = kid;
7885 cLISTOPo->op_last = kid;
7886 kid = kid->op_sibling;
7891 op_append_elem(o->op_type, o, newDEFSVOP());
7897 Perl_ck_smartmatch(pTHX_ OP *o)
7900 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7901 if (0 == (o->op_flags & OPf_SPECIAL)) {
7902 OP *first = cBINOPo->op_first;
7903 OP *second = first->op_sibling;
7905 /* Implicitly take a reference to an array or hash */
7906 first->op_sibling = NULL;
7907 first = cBINOPo->op_first = ref_array_or_hash(first);
7908 second = first->op_sibling = ref_array_or_hash(second);
7910 /* Implicitly take a reference to a regular expression */
7911 if (first->op_type == OP_MATCH) {
7912 first->op_type = OP_QR;
7913 first->op_ppaddr = PL_ppaddr[OP_QR];
7915 if (second->op_type == OP_MATCH) {
7916 second->op_type = OP_QR;
7917 second->op_ppaddr = PL_ppaddr[OP_QR];
7926 Perl_ck_sassign(pTHX_ OP *o)
7929 OP * const kid = cLISTOPo->op_first;
7931 PERL_ARGS_ASSERT_CK_SASSIGN;
7933 /* has a disposable target? */
7934 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7935 && !(kid->op_flags & OPf_STACKED)
7936 /* Cannot steal the second time! */
7937 && !(kid->op_private & OPpTARGET_MY)
7938 /* Keep the full thing for madskills */
7942 OP * const kkid = kid->op_sibling;
7944 /* Can just relocate the target. */
7945 if (kkid && kkid->op_type == OP_PADSV
7946 && !(kkid->op_private & OPpLVAL_INTRO))
7948 kid->op_targ = kkid->op_targ;
7950 /* Now we do not need PADSV and SASSIGN. */
7951 kid->op_sibling = o->op_sibling; /* NULL */
7952 cLISTOPo->op_first = NULL;
7955 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7959 if (kid->op_sibling) {
7960 OP *kkid = kid->op_sibling;
7961 if (kkid->op_type == OP_PADSV
7962 && (kkid->op_private & OPpLVAL_INTRO)
7963 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7964 const PADOFFSET target = kkid->op_targ;
7965 OP *const other = newOP(OP_PADSV,
7967 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7968 OP *const first = newOP(OP_NULL, 0);
7969 OP *const nullop = newCONDOP(0, first, o, other);
7970 OP *const condop = first->op_next;
7971 /* hijacking PADSTALE for uninitialized state variables */
7972 SvPADSTALE_on(PAD_SVl(target));
7974 condop->op_type = OP_ONCE;
7975 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7976 condop->op_targ = target;
7977 other->op_targ = target;
7979 /* Because we change the type of the op here, we will skip the
7980 assinment binop->op_last = binop->op_first->op_sibling; at the
7981 end of Perl_newBINOP(). So need to do it here. */
7982 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7991 Perl_ck_match(pTHX_ OP *o)
7995 PERL_ARGS_ASSERT_CK_MATCH;
7997 if (o->op_type != OP_QR && PL_compcv) {
7998 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7999 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8000 o->op_targ = offset;
8001 o->op_private |= OPpTARGET_MY;
8004 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8005 o->op_private |= OPpRUNTIME;
8010 Perl_ck_method(pTHX_ OP *o)
8012 OP * const kid = cUNOPo->op_first;
8014 PERL_ARGS_ASSERT_CK_METHOD;
8016 if (kid->op_type == OP_CONST) {
8017 SV* sv = kSVOP->op_sv;
8018 const char * const method = SvPVX_const(sv);
8019 if (!(strchr(method, ':') || strchr(method, '\''))) {
8021 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8022 sv = newSVpvn_share(method, SvCUR(sv), 0);
8025 kSVOP->op_sv = NULL;
8027 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8029 op_getmad(o,cmop,'O');
8040 Perl_ck_null(pTHX_ OP *o)
8042 PERL_ARGS_ASSERT_CK_NULL;
8043 PERL_UNUSED_CONTEXT;
8048 Perl_ck_open(pTHX_ OP *o)
8051 HV * const table = GvHV(PL_hintgv);
8053 PERL_ARGS_ASSERT_CK_OPEN;
8056 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8059 const char *d = SvPV_const(*svp, len);
8060 const I32 mode = mode_from_discipline(d, len);
8061 if (mode & O_BINARY)
8062 o->op_private |= OPpOPEN_IN_RAW;
8063 else if (mode & O_TEXT)
8064 o->op_private |= OPpOPEN_IN_CRLF;
8067 svp = hv_fetchs(table, "open_OUT", FALSE);
8070 const char *d = SvPV_const(*svp, len);
8071 const I32 mode = mode_from_discipline(d, len);
8072 if (mode & O_BINARY)
8073 o->op_private |= OPpOPEN_OUT_RAW;
8074 else if (mode & O_TEXT)
8075 o->op_private |= OPpOPEN_OUT_CRLF;
8078 if (o->op_type == OP_BACKTICK) {
8079 if (!(o->op_flags & OPf_KIDS)) {
8080 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8082 op_getmad(o,newop,'O');
8091 /* In case of three-arg dup open remove strictness
8092 * from the last arg if it is a bareword. */
8093 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8094 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8098 if ((last->op_type == OP_CONST) && /* The bareword. */
8099 (last->op_private & OPpCONST_BARE) &&
8100 (last->op_private & OPpCONST_STRICT) &&
8101 (oa = first->op_sibling) && /* The fh. */
8102 (oa = oa->op_sibling) && /* The mode. */
8103 (oa->op_type == OP_CONST) &&
8104 SvPOK(((SVOP*)oa)->op_sv) &&
8105 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8106 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8107 (last == oa->op_sibling)) /* The bareword. */
8108 last->op_private &= ~OPpCONST_STRICT;
8114 Perl_ck_repeat(pTHX_ OP *o)
8116 PERL_ARGS_ASSERT_CK_REPEAT;
8118 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8119 o->op_private |= OPpREPEAT_DOLIST;
8120 cBINOPo->op_first = force_list(cBINOPo->op_first);
8128 Perl_ck_require(pTHX_ OP *o)
8133 PERL_ARGS_ASSERT_CK_REQUIRE;
8135 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8136 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8138 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8139 SV * const sv = kid->op_sv;
8140 U32 was_readonly = SvREADONLY(sv);
8147 sv_force_normal_flags(sv, 0);
8148 assert(!SvREADONLY(sv));
8158 for (; s < end; s++) {
8159 if (*s == ':' && s[1] == ':') {
8161 Move(s+2, s+1, end - s - 1, char);
8166 sv_catpvs(sv, ".pm");
8167 SvFLAGS(sv) |= was_readonly;
8171 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8172 /* handle override, if any */
8173 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8174 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8175 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8176 gv = gvp ? *gvp : NULL;
8180 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8181 OP * const kid = cUNOPo->op_first;
8184 cUNOPo->op_first = 0;
8188 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8189 op_append_elem(OP_LIST, kid,
8190 scalar(newUNOP(OP_RV2CV, 0,
8193 op_getmad(o,newop,'O');
8197 return scalar(ck_fun(o));
8201 Perl_ck_return(pTHX_ OP *o)
8206 PERL_ARGS_ASSERT_CK_RETURN;
8208 kid = cLISTOPo->op_first->op_sibling;
8209 if (CvLVALUE(PL_compcv)) {
8210 for (; kid; kid = kid->op_sibling)
8211 op_lvalue(kid, OP_LEAVESUBLV);
8213 for (; kid; kid = kid->op_sibling)
8214 if ((kid->op_type == OP_NULL)
8215 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8216 /* This is a do block */
8217 OP *op = kUNOP->op_first;
8218 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8219 op = cUNOPx(op)->op_first;
8220 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8221 /* Force the use of the caller's context */
8222 op->op_flags |= OPf_SPECIAL;
8231 Perl_ck_select(pTHX_ OP *o)
8236 PERL_ARGS_ASSERT_CK_SELECT;
8238 if (o->op_flags & OPf_KIDS) {
8239 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8240 if (kid && kid->op_sibling) {
8241 o->op_type = OP_SSELECT;
8242 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8244 return fold_constants(o);
8248 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8249 if (kid && kid->op_type == OP_RV2GV)
8250 kid->op_private &= ~HINT_STRICT_REFS;
8255 Perl_ck_shift(pTHX_ OP *o)
8258 const I32 type = o->op_type;
8260 PERL_ARGS_ASSERT_CK_SHIFT;
8262 if (!(o->op_flags & OPf_KIDS)) {
8265 if (!CvUNIQUE(PL_compcv)) {
8266 o->op_flags |= OPf_SPECIAL;
8270 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8273 OP * const oldo = o;
8274 o = newUNOP(type, 0, scalar(argop));
8275 op_getmad(oldo,o,'O');
8280 return newUNOP(type, 0, scalar(argop));
8283 return scalar(modkids(ck_push(o), type));
8287 Perl_ck_sort(pTHX_ OP *o)
8292 PERL_ARGS_ASSERT_CK_SORT;
8294 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8295 HV * const hinthv = GvHV(PL_hintgv);
8297 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8299 const I32 sorthints = (I32)SvIV(*svp);
8300 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8301 o->op_private |= OPpSORT_QSORT;
8302 if ((sorthints & HINT_SORT_STABLE) != 0)
8303 o->op_private |= OPpSORT_STABLE;
8308 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8310 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8311 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8313 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8315 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8317 if (kid->op_type == OP_SCOPE) {
8321 else if (kid->op_type == OP_LEAVE) {
8322 if (o->op_type == OP_SORT) {
8323 op_null(kid); /* wipe out leave */
8326 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8327 if (k->op_next == kid)
8329 /* don't descend into loops */
8330 else if (k->op_type == OP_ENTERLOOP
8331 || k->op_type == OP_ENTERITER)
8333 k = cLOOPx(k)->op_lastop;
8338 kid->op_next = 0; /* just disconnect the leave */
8339 k = kLISTOP->op_first;
8344 if (o->op_type == OP_SORT) {
8345 /* provide scalar context for comparison function/block */
8351 o->op_flags |= OPf_SPECIAL;
8353 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8356 firstkid = firstkid->op_sibling;
8359 /* provide list context for arguments */
8360 if (o->op_type == OP_SORT)
8367 S_simplify_sort(pTHX_ OP *o)
8370 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8376 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8378 if (!(o->op_flags & OPf_STACKED))
8380 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8381 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8382 kid = kUNOP->op_first; /* get past null */
8383 if (kid->op_type != OP_SCOPE)
8385 kid = kLISTOP->op_last; /* get past scope */
8386 switch(kid->op_type) {
8394 k = kid; /* remember this node*/
8395 if (kBINOP->op_first->op_type != OP_RV2SV)
8397 kid = kBINOP->op_first; /* get past cmp */
8398 if (kUNOP->op_first->op_type != OP_GV)
8400 kid = kUNOP->op_first; /* get past rv2sv */
8402 if (GvSTASH(gv) != PL_curstash)
8404 gvname = GvNAME(gv);
8405 if (*gvname == 'a' && gvname[1] == '\0')
8407 else if (*gvname == 'b' && gvname[1] == '\0')
8412 kid = k; /* back to cmp */
8413 if (kBINOP->op_last->op_type != OP_RV2SV)
8415 kid = kBINOP->op_last; /* down to 2nd arg */
8416 if (kUNOP->op_first->op_type != OP_GV)
8418 kid = kUNOP->op_first; /* get past rv2sv */
8420 if (GvSTASH(gv) != PL_curstash)
8422 gvname = GvNAME(gv);
8424 ? !(*gvname == 'a' && gvname[1] == '\0')
8425 : !(*gvname == 'b' && gvname[1] == '\0'))
8427 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8429 o->op_private |= OPpSORT_DESCEND;
8430 if (k->op_type == OP_NCMP)
8431 o->op_private |= OPpSORT_NUMERIC;
8432 if (k->op_type == OP_I_NCMP)
8433 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8434 kid = cLISTOPo->op_first->op_sibling;
8435 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8437 op_getmad(kid,o,'S'); /* then delete it */
8439 op_free(kid); /* then delete it */
8444 Perl_ck_split(pTHX_ OP *o)
8449 PERL_ARGS_ASSERT_CK_SPLIT;
8451 if (o->op_flags & OPf_STACKED)
8452 return no_fh_allowed(o);
8454 kid = cLISTOPo->op_first;
8455 if (kid->op_type != OP_NULL)
8456 Perl_croak(aTHX_ "panic: ck_split");
8457 kid = kid->op_sibling;
8458 op_free(cLISTOPo->op_first);
8459 cLISTOPo->op_first = kid;
8461 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8462 cLISTOPo->op_last = kid; /* There was only one element previously */
8465 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8466 OP * const sibl = kid->op_sibling;
8467 kid->op_sibling = 0;
8468 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8469 if (cLISTOPo->op_first == cLISTOPo->op_last)
8470 cLISTOPo->op_last = kid;
8471 cLISTOPo->op_first = kid;
8472 kid->op_sibling = sibl;
8475 kid->op_type = OP_PUSHRE;
8476 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8478 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8479 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8480 "Use of /g modifier is meaningless in split");
8483 if (!kid->op_sibling)
8484 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8486 kid = kid->op_sibling;
8489 if (!kid->op_sibling)
8490 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8491 assert(kid->op_sibling);
8493 kid = kid->op_sibling;
8496 if (kid->op_sibling)
8497 return too_many_arguments(o,OP_DESC(o));
8503 Perl_ck_join(pTHX_ OP *o)
8505 const OP * const kid = cLISTOPo->op_first->op_sibling;
8507 PERL_ARGS_ASSERT_CK_JOIN;
8509 if (kid && kid->op_type == OP_MATCH) {
8510 if (ckWARN(WARN_SYNTAX)) {
8511 const REGEXP *re = PM_GETRE(kPMOP);
8512 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8513 const STRLEN len = re ? RX_PRELEN(re) : 6;
8514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8515 "/%.*s/ should probably be written as \"%.*s\"",
8516 (int)len, pmstr, (int)len, pmstr);
8523 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8525 Examines an op, which is expected to identify a subroutine at runtime,
8526 and attempts to determine at compile time which subroutine it identifies.
8527 This is normally used during Perl compilation to determine whether
8528 a prototype can be applied to a function call. I<cvop> is the op
8529 being considered, normally an C<rv2cv> op. A pointer to the identified
8530 subroutine is returned, if it could be determined statically, and a null
8531 pointer is returned if it was not possible to determine statically.
8533 Currently, the subroutine can be identified statically if the RV that the
8534 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8535 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8536 suitable if the constant value must be an RV pointing to a CV. Details of
8537 this process may change in future versions of Perl. If the C<rv2cv> op
8538 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8539 the subroutine statically: this flag is used to suppress compile-time
8540 magic on a subroutine call, forcing it to use default runtime behaviour.
8542 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8543 of a GV reference is modified. If a GV was examined and its CV slot was
8544 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8545 If the op is not optimised away, and the CV slot is later populated with
8546 a subroutine having a prototype, that flag eventually triggers the warning
8547 "called too early to check prototype".
8549 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8550 of returning a pointer to the subroutine it returns a pointer to the
8551 GV giving the most appropriate name for the subroutine in this context.
8552 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8553 (C<CvANON>) subroutine that is referenced through a GV it will be the
8554 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8555 A null pointer is returned as usual if there is no statically-determinable
8562 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8567 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8568 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8569 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8570 if (cvop->op_type != OP_RV2CV)
8572 if (cvop->op_private & OPpENTERSUB_AMPER)
8574 if (!(cvop->op_flags & OPf_KIDS))
8576 rvop = cUNOPx(cvop)->op_first;
8577 switch (rvop->op_type) {
8579 gv = cGVOPx_gv(rvop);
8582 if (flags & RV2CVOPCV_MARK_EARLY)
8583 rvop->op_private |= OPpEARLY_CV;
8588 SV *rv = cSVOPx_sv(rvop);
8598 if (SvTYPE((SV*)cv) != SVt_PVCV)
8600 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8601 if (!CvANON(cv) || !gv)
8610 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8612 Performs the default fixup of the arguments part of an C<entersub>
8613 op tree. This consists of applying list context to each of the
8614 argument ops. This is the standard treatment used on a call marked
8615 with C<&>, or a method call, or a call through a subroutine reference,
8616 or any other call where the callee can't be identified at compile time,
8617 or a call where the callee has no prototype.
8623 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8626 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8627 aop = cUNOPx(entersubop)->op_first;
8628 if (!aop->op_sibling)
8629 aop = cUNOPx(aop)->op_first;
8630 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8631 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8633 op_lvalue(aop, OP_ENTERSUB);
8640 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8642 Performs the fixup of the arguments part of an C<entersub> op tree
8643 based on a subroutine prototype. This makes various modifications to
8644 the argument ops, from applying context up to inserting C<refgen> ops,
8645 and checking the number and syntactic types of arguments, as directed by
8646 the prototype. This is the standard treatment used on a subroutine call,
8647 not marked with C<&>, where the callee can be identified at compile time
8648 and has a prototype.
8650 I<protosv> supplies the subroutine prototype to be applied to the call.
8651 It may be a normal defined scalar, of which the string value will be used.
8652 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8653 that has been cast to C<SV*>) which has a prototype. The prototype
8654 supplied, in whichever form, does not need to match the actual callee
8655 referenced by the op tree.
8657 If the argument ops disagree with the prototype, for example by having
8658 an unacceptable number of arguments, a valid op tree is returned anyway.
8659 The error is reflected in the parser state, normally resulting in a single
8660 exception at the top level of parsing which covers all the compilation
8661 errors that occurred. In the error message, the callee is referred to
8662 by the name defined by the I<namegv> parameter.
8668 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8671 const char *proto, *proto_end;
8672 OP *aop, *prev, *cvop;
8675 I32 contextclass = 0;
8676 const char *e = NULL;
8677 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8678 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8679 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8680 proto = SvPV(protosv, proto_len);
8681 proto_end = proto + proto_len;
8682 aop = cUNOPx(entersubop)->op_first;
8683 if (!aop->op_sibling)
8684 aop = cUNOPx(aop)->op_first;
8686 aop = aop->op_sibling;
8687 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8688 while (aop != cvop) {
8690 if (PL_madskills && aop->op_type == OP_STUB) {
8691 aop = aop->op_sibling;
8694 if (PL_madskills && aop->op_type == OP_NULL)
8695 o3 = ((UNOP*)aop)->op_first;
8699 if (proto >= proto_end)
8700 return too_many_arguments(entersubop, gv_ename(namegv));
8708 /* _ must be at the end */
8709 if (proto[1] && proto[1] != ';')
8724 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8726 arg == 1 ? "block or sub {}" : "sub {}",
8727 gv_ename(namegv), o3);
8730 /* '*' allows any scalar type, including bareword */
8733 if (o3->op_type == OP_RV2GV)
8734 goto wrapref; /* autoconvert GLOB -> GLOBref */
8735 else if (o3->op_type == OP_CONST)
8736 o3->op_private &= ~OPpCONST_STRICT;
8737 else if (o3->op_type == OP_ENTERSUB) {
8738 /* accidental subroutine, revert to bareword */
8739 OP *gvop = ((UNOP*)o3)->op_first;
8740 if (gvop && gvop->op_type == OP_NULL) {
8741 gvop = ((UNOP*)gvop)->op_first;
8743 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8746 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8747 (gvop = ((UNOP*)gvop)->op_first) &&
8748 gvop->op_type == OP_GV)
8750 GV * const gv = cGVOPx_gv(gvop);
8751 OP * const sibling = aop->op_sibling;
8752 SV * const n = newSVpvs("");
8754 OP * const oldaop = aop;
8758 gv_fullname4(n, gv, "", FALSE);
8759 aop = newSVOP(OP_CONST, 0, n);
8760 op_getmad(oldaop,aop,'O');
8761 prev->op_sibling = aop;
8762 aop->op_sibling = sibling;
8772 if (o3->op_type == OP_RV2AV ||
8773 o3->op_type == OP_PADAV ||
8774 o3->op_type == OP_RV2HV ||
8775 o3->op_type == OP_PADHV
8790 if (contextclass++ == 0) {
8791 e = strchr(proto, ']');
8792 if (!e || e == proto)
8801 const char *p = proto;
8802 const char *const end = proto;
8804 while (*--p != '[') {}
8805 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8807 gv_ename(namegv), o3);
8812 if (o3->op_type == OP_RV2GV)
8815 bad_type(arg, "symbol", gv_ename(namegv), o3);
8818 if (o3->op_type == OP_ENTERSUB)
8821 bad_type(arg, "subroutine entry", gv_ename(namegv),
8825 if (o3->op_type == OP_RV2SV ||
8826 o3->op_type == OP_PADSV ||
8827 o3->op_type == OP_HELEM ||
8828 o3->op_type == OP_AELEM)
8831 bad_type(arg, "scalar", gv_ename(namegv), o3);
8834 if (o3->op_type == OP_RV2AV ||
8835 o3->op_type == OP_PADAV)
8838 bad_type(arg, "array", gv_ename(namegv), o3);
8841 if (o3->op_type == OP_RV2HV ||
8842 o3->op_type == OP_PADHV)
8845 bad_type(arg, "hash", gv_ename(namegv), o3);
8849 OP* const kid = aop;
8850 OP* const sib = kid->op_sibling;
8851 kid->op_sibling = 0;
8852 aop = newUNOP(OP_REFGEN, 0, kid);
8853 aop->op_sibling = sib;
8854 prev->op_sibling = aop;
8856 if (contextclass && e) {
8871 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8872 gv_ename(namegv), SVfARG(protosv));
8875 op_lvalue(aop, OP_ENTERSUB);
8877 aop = aop->op_sibling;
8879 if (aop == cvop && *proto == '_') {
8880 /* generate an access to $_ */
8882 aop->op_sibling = prev->op_sibling;
8883 prev->op_sibling = aop; /* instead of cvop */
8885 if (!optional && proto_end > proto &&
8886 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8887 return too_few_arguments(entersubop, gv_ename(namegv));
8892 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8894 Performs the fixup of the arguments part of an C<entersub> op tree either
8895 based on a subroutine prototype or using default list-context processing.
8896 This is the standard treatment used on a subroutine call, not marked
8897 with C<&>, where the callee can be identified at compile time.
8899 I<protosv> supplies the subroutine prototype to be applied to the call,
8900 or indicates that there is no prototype. It may be a normal scalar,
8901 in which case if it is defined then the string value will be used
8902 as a prototype, and if it is undefined then there is no prototype.
8903 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8904 that has been cast to C<SV*>), of which the prototype will be used if it
8905 has one. The prototype (or lack thereof) supplied, in whichever form,
8906 does not need to match the actual callee referenced by the op tree.
8908 If the argument ops disagree with the prototype, for example by having
8909 an unacceptable number of arguments, a valid op tree is returned anyway.
8910 The error is reflected in the parser state, normally resulting in a single
8911 exception at the top level of parsing which covers all the compilation
8912 errors that occurred. In the error message, the callee is referred to
8913 by the name defined by the I<namegv> parameter.
8919 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8920 GV *namegv, SV *protosv)
8922 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8923 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8924 return ck_entersub_args_proto(entersubop, namegv, protosv);
8926 return ck_entersub_args_list(entersubop);
8930 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8932 Retrieves the function that will be used to fix up a call to I<cv>.
8933 Specifically, the function is applied to an C<entersub> op tree for a
8934 subroutine call, not marked with C<&>, where the callee can be identified
8935 at compile time as I<cv>.
8937 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8938 argument for it is returned in I<*ckobj_p>. The function is intended
8939 to be called in this manner:
8941 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8943 In this call, I<entersubop> is a pointer to the C<entersub> op,
8944 which may be replaced by the check function, and I<namegv> is a GV
8945 supplying the name that should be used by the check function to refer
8946 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8947 It is permitted to apply the check function in non-standard situations,
8948 such as to a call to a different subroutine or to a method call.
8950 By default, the function is
8951 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8952 and the SV parameter is I<cv> itself. This implements standard
8953 prototype processing. It can be changed, for a particular subroutine,
8954 by L</cv_set_call_checker>.
8960 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8963 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8964 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8966 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8967 *ckobj_p = callmg->mg_obj;
8969 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8975 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8977 Sets the function that will be used to fix up a call to I<cv>.
8978 Specifically, the function is applied to an C<entersub> op tree for a
8979 subroutine call, not marked with C<&>, where the callee can be identified
8980 at compile time as I<cv>.
8982 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8983 for it is supplied in I<ckobj>. The function is intended to be called
8986 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8988 In this call, I<entersubop> is a pointer to the C<entersub> op,
8989 which may be replaced by the check function, and I<namegv> is a GV
8990 supplying the name that should be used by the check function to refer
8991 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8992 It is permitted to apply the check function in non-standard situations,
8993 such as to a call to a different subroutine or to a method call.
8995 The current setting for a particular CV can be retrieved by
8996 L</cv_get_call_checker>.
9002 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9004 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9005 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9006 if (SvMAGICAL((SV*)cv))
9007 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9010 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9011 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9012 if (callmg->mg_flags & MGf_REFCOUNTED) {
9013 SvREFCNT_dec(callmg->mg_obj);
9014 callmg->mg_flags &= ~MGf_REFCOUNTED;
9016 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9017 callmg->mg_obj = ckobj;
9018 if (ckobj != (SV*)cv) {
9019 SvREFCNT_inc_simple_void_NN(ckobj);
9020 callmg->mg_flags |= MGf_REFCOUNTED;
9026 Perl_ck_subr(pTHX_ OP *o)
9032 PERL_ARGS_ASSERT_CK_SUBR;
9034 aop = cUNOPx(o)->op_first;
9035 if (!aop->op_sibling)
9036 aop = cUNOPx(aop)->op_first;
9037 aop = aop->op_sibling;
9038 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9039 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9040 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9042 o->op_private |= OPpENTERSUB_HASTARG;
9043 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9044 if (PERLDB_SUB && PL_curstash != PL_debstash)
9045 o->op_private |= OPpENTERSUB_DB;
9046 if (cvop->op_type == OP_RV2CV) {
9047 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9049 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9050 if (aop->op_type == OP_CONST)
9051 aop->op_private &= ~OPpCONST_STRICT;
9052 else if (aop->op_type == OP_LIST) {
9053 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9054 if (sib && sib->op_type == OP_CONST)
9055 sib->op_private &= ~OPpCONST_STRICT;
9060 return ck_entersub_args_list(o);
9062 Perl_call_checker ckfun;
9064 cv_get_call_checker(cv, &ckfun, &ckobj);
9065 return ckfun(aTHX_ o, namegv, ckobj);
9070 Perl_ck_svconst(pTHX_ OP *o)
9072 PERL_ARGS_ASSERT_CK_SVCONST;
9073 PERL_UNUSED_CONTEXT;
9074 SvREADONLY_on(cSVOPo->op_sv);
9079 Perl_ck_chdir(pTHX_ OP *o)
9081 PERL_ARGS_ASSERT_CK_CHDIR;
9082 if (o->op_flags & OPf_KIDS) {
9083 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9085 if (kid && kid->op_type == OP_CONST &&
9086 (kid->op_private & OPpCONST_BARE))
9088 o->op_flags |= OPf_SPECIAL;
9089 kid->op_private &= ~OPpCONST_STRICT;
9096 Perl_ck_trunc(pTHX_ OP *o)
9098 PERL_ARGS_ASSERT_CK_TRUNC;
9100 if (o->op_flags & OPf_KIDS) {
9101 SVOP *kid = (SVOP*)cUNOPo->op_first;
9103 if (kid->op_type == OP_NULL)
9104 kid = (SVOP*)kid->op_sibling;
9105 if (kid && kid->op_type == OP_CONST &&
9106 (kid->op_private & OPpCONST_BARE))
9108 o->op_flags |= OPf_SPECIAL;
9109 kid->op_private &= ~OPpCONST_STRICT;
9116 Perl_ck_unpack(pTHX_ OP *o)
9118 OP *kid = cLISTOPo->op_first;
9120 PERL_ARGS_ASSERT_CK_UNPACK;
9122 if (kid->op_sibling) {
9123 kid = kid->op_sibling;
9124 if (!kid->op_sibling)
9125 kid->op_sibling = newDEFSVOP();
9131 Perl_ck_substr(pTHX_ OP *o)
9133 PERL_ARGS_ASSERT_CK_SUBSTR;
9136 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9137 OP *kid = cLISTOPo->op_first;
9139 if (kid->op_type == OP_NULL)
9140 kid = kid->op_sibling;
9142 kid->op_flags |= OPf_MOD;
9149 Perl_ck_push(pTHX_ OP *o)
9152 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9156 PERL_ARGS_ASSERT_CK_PUSH;
9158 /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
9160 cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
9163 /* If not array or array deref, wrap it with an array deref.
9164 * For OP_CONST, we only wrap arrayrefs */
9166 if ( ( cursor->op_type != OP_PADAV
9167 && cursor->op_type != OP_RV2AV
9168 && cursor->op_type != OP_CONST
9171 ( cursor->op_type == OP_CONST
9172 && SvROK(cSVOPx_sv(cursor))
9173 && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
9176 proxy = newAVREF(cursor);
9177 if ( cursor == kid ) {
9178 cLISTOPx(o)->op_first = proxy;
9181 cLISTOPx(kid)->op_sibling = proxy;
9183 cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
9184 cLISTOPx(cursor)->op_sibling = NULL;
9191 Perl_ck_each(pTHX_ OP *o)
9194 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9195 const unsigned orig_type = o->op_type;
9196 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9197 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9198 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9199 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9201 PERL_ARGS_ASSERT_CK_EACH;
9204 switch (kid->op_type) {
9210 CHANGE_TYPE(o, array_type);
9213 if (kid->op_private == OPpCONST_BARE)
9214 /* we let ck_fun treat as hash */
9217 CHANGE_TYPE(o, ref_type);
9220 /* if treating as a reference, defer additional checks to runtime */
9221 return o->op_type == ref_type ? o : ck_fun(o);
9224 /* caller is supposed to assign the return to the
9225 container of the rep_op var */
9227 S_opt_scalarhv(pTHX_ OP *rep_op) {
9231 PERL_ARGS_ASSERT_OPT_SCALARHV;
9233 NewOp(1101, unop, 1, UNOP);
9234 unop->op_type = (OPCODE)OP_BOOLKEYS;
9235 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9236 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9237 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9238 unop->op_first = rep_op;
9239 unop->op_next = rep_op->op_next;
9240 rep_op->op_next = (OP*)unop;
9241 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9242 unop->op_sibling = rep_op->op_sibling;
9243 rep_op->op_sibling = NULL;
9244 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9245 if (rep_op->op_type == OP_PADHV) {
9246 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9247 rep_op->op_flags |= OPf_WANT_LIST;
9252 /* Checks if o acts as an in-place operator on an array. oright points to the
9253 * beginning of the right-hand side. Returns the left-hand side of the
9254 * assignment if o acts in-place, or NULL otherwise. */
9257 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9261 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9264 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9265 || oright->op_next != o
9266 || (oright->op_private & OPpLVAL_INTRO)
9270 /* o2 follows the chain of op_nexts through the LHS of the
9271 * assign (if any) to the aassign op itself */
9273 if (!o2 || o2->op_type != OP_NULL)
9276 if (!o2 || o2->op_type != OP_PUSHMARK)
9279 if (o2 && o2->op_type == OP_GV)
9282 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9283 || (o2->op_private & OPpLVAL_INTRO)
9288 if (!o2 || o2->op_type != OP_NULL)
9291 if (!o2 || o2->op_type != OP_AASSIGN
9292 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9295 /* check that the sort is the first arg on RHS of assign */
9297 o2 = cUNOPx(o2)->op_first;
9298 if (!o2 || o2->op_type != OP_NULL)
9300 o2 = cUNOPx(o2)->op_first;
9301 if (!o2 || o2->op_type != OP_PUSHMARK)
9303 if (o2->op_sibling != o)
9306 /* check the array is the same on both sides */
9307 if (oleft->op_type == OP_RV2AV) {
9308 if (oright->op_type != OP_RV2AV
9309 || !cUNOPx(oright)->op_first
9310 || cUNOPx(oright)->op_first->op_type != OP_GV
9311 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9312 cGVOPx_gv(cUNOPx(oright)->op_first)
9316 else if (oright->op_type != OP_PADAV
9317 || oright->op_targ != oleft->op_targ
9324 /* A peephole optimizer. We visit the ops in the order they're to execute.
9325 * See the comments at the top of this file for more details about when
9326 * peep() is called */
9329 Perl_rpeep(pTHX_ register OP *o)
9332 register OP* oldop = NULL;
9334 if (!o || o->op_opt)
9338 SAVEVPTR(PL_curcop);
9339 for (; o; o = o->op_next) {
9342 /* By default, this op has now been optimised. A couple of cases below
9343 clear this again. */
9346 switch (o->op_type) {
9348 PL_curcop = ((COP*)o); /* for warnings */
9351 PL_curcop = ((COP*)o); /* for warnings */
9353 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9354 to carry two labels. For now, take the easier option, and skip
9355 this optimisation if the first NEXTSTATE has a label. */
9356 if (!CopLABEL((COP*)o)) {
9357 OP *nextop = o->op_next;
9358 while (nextop && nextop->op_type == OP_NULL)
9359 nextop = nextop->op_next;
9361 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9362 COP *firstcop = (COP *)o;
9363 COP *secondcop = (COP *)nextop;
9364 /* We want the COP pointed to by o (and anything else) to
9365 become the next COP down the line. */
9368 firstcop->op_next = secondcop->op_next;
9370 /* Now steal all its pointers, and duplicate the other
9372 firstcop->cop_line = secondcop->cop_line;
9374 firstcop->cop_stashpv = secondcop->cop_stashpv;
9375 firstcop->cop_file = secondcop->cop_file;
9377 firstcop->cop_stash = secondcop->cop_stash;
9378 firstcop->cop_filegv = secondcop->cop_filegv;
9380 firstcop->cop_hints = secondcop->cop_hints;
9381 firstcop->cop_seq = secondcop->cop_seq;
9382 firstcop->cop_warnings = secondcop->cop_warnings;
9383 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9386 secondcop->cop_stashpv = NULL;
9387 secondcop->cop_file = NULL;
9389 secondcop->cop_stash = NULL;
9390 secondcop->cop_filegv = NULL;
9392 secondcop->cop_warnings = NULL;
9393 secondcop->cop_hints_hash = NULL;
9395 /* If we use op_null(), and hence leave an ex-COP, some
9396 warnings are misreported. For example, the compile-time
9397 error in 'use strict; no strict refs;' */
9398 secondcop->op_type = OP_NULL;
9399 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9405 if (cSVOPo->op_private & OPpCONST_STRICT)
9406 no_bareword_allowed(o);
9409 case OP_METHOD_NAMED:
9410 /* Relocate sv to the pad for thread safety.
9411 * Despite being a "constant", the SV is written to,
9412 * for reference counts, sv_upgrade() etc. */
9414 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9415 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9416 /* If op_sv is already a PADTMP then it is being used by
9417 * some pad, so make a copy. */
9418 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9419 SvREADONLY_on(PAD_SVl(ix));
9420 SvREFCNT_dec(cSVOPo->op_sv);
9422 else if (o->op_type != OP_METHOD_NAMED
9423 && cSVOPo->op_sv == &PL_sv_undef) {
9424 /* PL_sv_undef is hack - it's unsafe to store it in the
9425 AV that is the pad, because av_fetch treats values of
9426 PL_sv_undef as a "free" AV entry and will merrily
9427 replace them with a new SV, causing pad_alloc to think
9428 that this pad slot is free. (When, clearly, it is not)
9430 SvOK_off(PAD_SVl(ix));
9431 SvPADTMP_on(PAD_SVl(ix));
9432 SvREADONLY_on(PAD_SVl(ix));
9435 SvREFCNT_dec(PAD_SVl(ix));
9436 SvPADTMP_on(cSVOPo->op_sv);
9437 PAD_SETSV(ix, cSVOPo->op_sv);
9438 /* XXX I don't know how this isn't readonly already. */
9439 SvREADONLY_on(PAD_SVl(ix));
9441 cSVOPo->op_sv = NULL;
9448 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9449 if (o->op_next->op_private & OPpTARGET_MY) {
9450 if (o->op_flags & OPf_STACKED) /* chained concats */
9451 break; /* ignore_optimization */
9453 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9454 o->op_targ = o->op_next->op_targ;
9455 o->op_next->op_targ = 0;
9456 o->op_private |= OPpTARGET_MY;
9459 op_null(o->op_next);
9463 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9464 break; /* Scalar stub must produce undef. List stub is noop */
9468 if (o->op_targ == OP_NEXTSTATE
9469 || o->op_targ == OP_DBSTATE)
9471 PL_curcop = ((COP*)o);
9473 /* XXX: We avoid setting op_seq here to prevent later calls
9474 to rpeep() from mistakenly concluding that optimisation
9475 has already occurred. This doesn't fix the real problem,
9476 though (See 20010220.007). AMS 20010719 */
9477 /* op_seq functionality is now replaced by op_opt */
9484 if (oldop && o->op_next) {
9485 oldop->op_next = o->op_next;
9493 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9494 OP* const pop = (o->op_type == OP_PADAV) ?
9495 o->op_next : o->op_next->op_next;
9497 if (pop && pop->op_type == OP_CONST &&
9498 ((PL_op = pop->op_next)) &&
9499 pop->op_next->op_type == OP_AELEM &&
9500 !(pop->op_next->op_private &
9501 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9502 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9507 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9508 no_bareword_allowed(pop);
9509 if (o->op_type == OP_GV)
9510 op_null(o->op_next);
9511 op_null(pop->op_next);
9513 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9514 o->op_next = pop->op_next->op_next;
9515 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9516 o->op_private = (U8)i;
9517 if (o->op_type == OP_GV) {
9522 o->op_flags |= OPf_SPECIAL;
9523 o->op_type = OP_AELEMFAST;
9528 if (o->op_next->op_type == OP_RV2SV) {
9529 if (!(o->op_next->op_private & OPpDEREF)) {
9530 op_null(o->op_next);
9531 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9533 o->op_next = o->op_next->op_next;
9534 o->op_type = OP_GVSV;
9535 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9538 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9539 GV * const gv = cGVOPo_gv;
9540 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9541 /* XXX could check prototype here instead of just carping */
9542 SV * const sv = sv_newmortal();
9543 gv_efullname3(sv, gv, NULL);
9544 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9545 "%"SVf"() called too early to check prototype",
9549 else if (o->op_next->op_type == OP_READLINE
9550 && o->op_next->op_next->op_type == OP_CONCAT
9551 && (o->op_next->op_next->op_flags & OPf_STACKED))
9553 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9554 o->op_type = OP_RCATLINE;
9555 o->op_flags |= OPf_STACKED;
9556 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9557 op_null(o->op_next->op_next);
9558 op_null(o->op_next);
9568 fop = cUNOP->op_first;
9576 fop = cLOGOP->op_first;
9577 sop = fop->op_sibling;
9578 while (cLOGOP->op_other->op_type == OP_NULL)
9579 cLOGOP->op_other = cLOGOP->op_other->op_next;
9580 CALL_RPEEP(cLOGOP->op_other);
9584 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9586 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9591 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9592 while (nop && nop->op_next) {
9593 switch (nop->op_next->op_type) {
9598 lop = nop = nop->op_next;
9609 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9610 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9611 cLOGOP->op_first = opt_scalarhv(fop);
9612 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9613 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9629 while (cLOGOP->op_other->op_type == OP_NULL)
9630 cLOGOP->op_other = cLOGOP->op_other->op_next;
9631 CALL_RPEEP(cLOGOP->op_other);
9636 while (cLOOP->op_redoop->op_type == OP_NULL)
9637 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9638 CALL_RPEEP(cLOOP->op_redoop);
9639 while (cLOOP->op_nextop->op_type == OP_NULL)
9640 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9641 CALL_RPEEP(cLOOP->op_nextop);
9642 while (cLOOP->op_lastop->op_type == OP_NULL)
9643 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9644 CALL_RPEEP(cLOOP->op_lastop);
9648 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9649 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9650 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9651 cPMOP->op_pmstashstartu.op_pmreplstart
9652 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9653 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9657 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9658 && ckWARN(WARN_SYNTAX))
9660 if (o->op_next->op_sibling) {
9661 const OPCODE type = o->op_next->op_sibling->op_type;
9662 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9663 const line_t oldline = CopLINE(PL_curcop);
9664 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9665 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9666 "Statement unlikely to be reached");
9667 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9668 "\t(Maybe you meant system() when you said exec()?)\n");
9669 CopLINE_set(PL_curcop, oldline);
9680 const char *key = NULL;
9683 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9686 /* Make the CONST have a shared SV */
9687 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9688 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9689 key = SvPV_const(sv, keylen);
9690 lexname = newSVpvn_share(key,
9691 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9697 if ((o->op_private & (OPpLVAL_INTRO)))
9700 rop = (UNOP*)((BINOP*)o)->op_first;
9701 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9703 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9704 if (!SvPAD_TYPED(lexname))
9706 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9707 if (!fields || !GvHV(*fields))
9709 key = SvPV_const(*svp, keylen);
9710 if (!hv_fetch(GvHV(*fields), key,
9711 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9713 Perl_croak(aTHX_ "No such class field \"%s\" "
9714 "in variable %s of type %s",
9715 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9728 SVOP *first_key_op, *key_op;
9730 if ((o->op_private & (OPpLVAL_INTRO))
9731 /* I bet there's always a pushmark... */
9732 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9733 /* hmmm, no optimization if list contains only one key. */
9735 rop = (UNOP*)((LISTOP*)o)->op_last;
9736 if (rop->op_type != OP_RV2HV)
9738 if (rop->op_first->op_type == OP_PADSV)
9739 /* @$hash{qw(keys here)} */
9740 rop = (UNOP*)rop->op_first;
9742 /* @{$hash}{qw(keys here)} */
9743 if (rop->op_first->op_type == OP_SCOPE
9744 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9746 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9752 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9753 if (!SvPAD_TYPED(lexname))
9755 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9756 if (!fields || !GvHV(*fields))
9758 /* Again guessing that the pushmark can be jumped over.... */
9759 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9760 ->op_first->op_sibling;
9761 for (key_op = first_key_op; key_op;
9762 key_op = (SVOP*)key_op->op_sibling) {
9763 if (key_op->op_type != OP_CONST)
9765 svp = cSVOPx_svp(key_op);
9766 key = SvPV_const(*svp, keylen);
9767 if (!hv_fetch(GvHV(*fields), key,
9768 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9770 Perl_croak(aTHX_ "No such class field \"%s\" "
9771 "in variable %s of type %s",
9772 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9781 && ( oldop->op_type == OP_AELEM
9782 || oldop->op_type == OP_PADSV
9783 || oldop->op_type == OP_RV2SV
9784 || oldop->op_type == OP_RV2GV
9785 || oldop->op_type == OP_HELEM
9787 && (oldop->op_private & OPpDEREF)
9789 o->op_private |= OPpDEREFed;
9793 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9797 /* check that RHS of sort is a single plain array */
9798 OP *oright = cUNOPo->op_first;
9799 if (!oright || oright->op_type != OP_PUSHMARK)
9802 /* reverse sort ... can be optimised. */
9803 if (!cUNOPo->op_sibling) {
9804 /* Nothing follows us on the list. */
9805 OP * const reverse = o->op_next;
9807 if (reverse->op_type == OP_REVERSE &&
9808 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9809 OP * const pushmark = cUNOPx(reverse)->op_first;
9810 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9811 && (cUNOPx(pushmark)->op_sibling == o)) {
9812 /* reverse -> pushmark -> sort */
9813 o->op_private |= OPpSORT_REVERSE;
9815 pushmark->op_next = oright->op_next;
9821 /* make @a = sort @a act in-place */
9823 oright = cUNOPx(oright)->op_sibling;
9826 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9827 oright = cUNOPx(oright)->op_sibling;
9830 oleft = is_inplace_av(o, oright);
9834 /* transfer MODishness etc from LHS arg to RHS arg */
9835 oright->op_flags = oleft->op_flags;
9836 o->op_private |= OPpSORT_INPLACE;
9838 /* excise push->gv->rv2av->null->aassign */
9839 o2 = o->op_next->op_next;
9840 op_null(o2); /* PUSHMARK */
9842 if (o2->op_type == OP_GV) {
9843 op_null(o2); /* GV */
9846 op_null(o2); /* RV2AV or PADAV */
9847 o2 = o2->op_next->op_next;
9848 op_null(o2); /* AASSIGN */
9850 o->op_next = o2->op_next;
9856 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9859 LISTOP *enter, *exlist;
9861 /* @a = reverse @a */
9862 if ((oright = cLISTOPo->op_first)
9863 && (oright->op_type == OP_PUSHMARK)
9864 && (oright = oright->op_sibling)
9865 && (oleft = is_inplace_av(o, oright))) {
9868 /* transfer MODishness etc from LHS arg to RHS arg */
9869 oright->op_flags = oleft->op_flags;
9870 o->op_private |= OPpREVERSE_INPLACE;
9872 /* excise push->gv->rv2av->null->aassign */
9873 o2 = o->op_next->op_next;
9874 op_null(o2); /* PUSHMARK */
9876 if (o2->op_type == OP_GV) {
9877 op_null(o2); /* GV */
9880 op_null(o2); /* RV2AV or PADAV */
9881 o2 = o2->op_next->op_next;
9882 op_null(o2); /* AASSIGN */
9884 o->op_next = o2->op_next;
9888 enter = (LISTOP *) o->op_next;
9891 if (enter->op_type == OP_NULL) {
9892 enter = (LISTOP *) enter->op_next;
9896 /* for $a (...) will have OP_GV then OP_RV2GV here.
9897 for (...) just has an OP_GV. */
9898 if (enter->op_type == OP_GV) {
9899 gvop = (OP *) enter;
9900 enter = (LISTOP *) enter->op_next;
9903 if (enter->op_type == OP_RV2GV) {
9904 enter = (LISTOP *) enter->op_next;
9910 if (enter->op_type != OP_ENTERITER)
9913 iter = enter->op_next;
9914 if (!iter || iter->op_type != OP_ITER)
9917 expushmark = enter->op_first;
9918 if (!expushmark || expushmark->op_type != OP_NULL
9919 || expushmark->op_targ != OP_PUSHMARK)
9922 exlist = (LISTOP *) expushmark->op_sibling;
9923 if (!exlist || exlist->op_type != OP_NULL
9924 || exlist->op_targ != OP_LIST)
9927 if (exlist->op_last != o) {
9928 /* Mmm. Was expecting to point back to this op. */
9931 theirmark = exlist->op_first;
9932 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9935 if (theirmark->op_sibling != o) {
9936 /* There's something between the mark and the reverse, eg
9937 for (1, reverse (...))
9942 ourmark = ((LISTOP *)o)->op_first;
9943 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9946 ourlast = ((LISTOP *)o)->op_last;
9947 if (!ourlast || ourlast->op_next != o)
9950 rv2av = ourmark->op_sibling;
9951 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9952 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9953 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9954 /* We're just reversing a single array. */
9955 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9956 enter->op_flags |= OPf_STACKED;
9959 /* We don't have control over who points to theirmark, so sacrifice
9961 theirmark->op_next = ourmark->op_next;
9962 theirmark->op_flags = ourmark->op_flags;
9963 ourlast->op_next = gvop ? gvop : (OP *) enter;
9966 enter->op_private |= OPpITER_REVERSED;
9967 iter->op_private |= OPpITER_REVERSED;
9974 UNOP *refgen, *rv2cv;
9977 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9980 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9983 rv2gv = ((BINOP *)o)->op_last;
9984 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9987 refgen = (UNOP *)((BINOP *)o)->op_first;
9989 if (!refgen || refgen->op_type != OP_REFGEN)
9992 exlist = (LISTOP *)refgen->op_first;
9993 if (!exlist || exlist->op_type != OP_NULL
9994 || exlist->op_targ != OP_LIST)
9997 if (exlist->op_first->op_type != OP_PUSHMARK)
10000 rv2cv = (UNOP*)exlist->op_last;
10002 if (rv2cv->op_type != OP_RV2CV)
10005 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
10006 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
10007 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
10009 o->op_private |= OPpASSIGN_CV_TO_GV;
10010 rv2gv->op_private |= OPpDONT_INIT_GV;
10011 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
10019 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10020 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10030 Perl_peep(pTHX_ register OP *o)
10036 Perl_custom_op_name(pTHX_ const OP* o)
10039 const IV index = PTR2IV(o->op_ppaddr);
10043 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
10045 if (!PL_custom_op_names) /* This probably shouldn't happen */
10046 return (char *)PL_op_name[OP_CUSTOM];
10048 keysv = sv_2mortal(newSViv(index));
10050 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
10052 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
10054 return SvPV_nolen(HeVAL(he));
10058 Perl_custom_op_desc(pTHX_ const OP* o)
10061 const IV index = PTR2IV(o->op_ppaddr);
10065 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
10067 if (!PL_custom_op_descs)
10068 return (char *)PL_op_desc[OP_CUSTOM];
10070 keysv = sv_2mortal(newSViv(index));
10072 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
10074 return (char *)PL_op_desc[OP_CUSTOM];
10076 return SvPV_nolen(HeVAL(he));
10081 /* Efficient sub that returns a constant scalar value. */
10083 const_sv_xsub(pTHX_ CV* cv)
10087 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10091 /* diag_listed_as: SKIPME */
10092 Perl_croak(aTHX_ "usage: %s::%s()",
10093 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10106 * c-indentation-style: bsd
10107 * c-basic-offset: 4
10108 * indent-tabs-mode: t
10111 * ex: set ts=8 sts=4 sw=4 noet: