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)
314 S_gv_ename(pTHX_ GV *gv)
316 SV* const tmpsv = sv_newmortal();
318 PERL_ARGS_ASSERT_GV_ENAME;
320 gv_efullname3(tmpsv, gv, NULL);
321 return SvPV_nolen_const(tmpsv);
325 S_no_fh_allowed(pTHX_ OP *o)
327 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
329 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
335 S_too_few_arguments(pTHX_ OP *o, const char *name)
337 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
339 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
344 S_too_many_arguments(pTHX_ OP *o, const char *name)
346 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
348 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
353 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
355 PERL_ARGS_ASSERT_BAD_TYPE;
357 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
358 (int)n, name, t, OP_DESC(kid)));
362 S_no_bareword_allowed(pTHX_ const OP *o)
364 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
367 return; /* various ok barewords are hidden in extra OP_NULL */
368 qerror(Perl_mess(aTHX_
369 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
373 /* "register" allocation */
376 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
380 const bool is_our = (PL_parser->in_my == KEY_our);
382 PERL_ARGS_ASSERT_ALLOCMY;
385 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
388 /* Until we're using the length for real, cross check that we're being
390 assert(strlen(name) == len);
392 /* complain about "my $<special_var>" etc etc */
396 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
397 (name[1] == '_' && (*name == '$' || len > 2))))
399 /* name[2] is true if strlen(name) > 2 */
400 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
401 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
402 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
403 PL_parser->in_my == KEY_state ? "state" : "my"));
405 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
406 PL_parser->in_my == KEY_state ? "state" : "my"));
410 /* allocate a spare slot and store the name in that slot */
412 off = pad_add_name(name, len,
413 is_our ? padadd_OUR :
414 PL_parser->in_my == KEY_state ? padadd_STATE : 0,
415 PL_parser->in_my_stash,
417 /* $_ is always in main::, even with our */
418 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
422 /* anon sub prototypes contains state vars should always be cloned,
423 * otherwise the state var would be shared between anon subs */
425 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
426 CvCLONE_on(PL_compcv);
431 /* free the body of an op without examining its contents.
432 * Always use this rather than FreeOp directly */
435 S_op_destroy(pTHX_ OP *o)
437 if (o->op_latefree) {
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
447 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
453 Perl_op_free(pTHX_ OP *o)
460 if (o->op_latefreed) {
467 if (o->op_private & OPpREFCOUNTED) {
478 refcnt = OpREFCNT_dec(o);
481 /* Need to find and remove any pattern match ops from the list
482 we maintain for reset(). */
483 find_and_forget_pmops(o);
493 /* Call the op_free hook if it has been set. Do it now so that it's called
494 * at the right time for refcounted ops, but still before all of the kids
498 if (o->op_flags & OPf_KIDS) {
499 register OP *kid, *nextkid;
500 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
501 nextkid = kid->op_sibling; /* Get before next freeing kid */
506 #ifdef PERL_DEBUG_READONLY_OPS
510 /* COP* is not cleared by op_clear() so that we may track line
511 * numbers etc even after null() */
512 if (type == OP_NEXTSTATE || type == OP_DBSTATE
513 || (type == OP_NULL /* the COP might have been null'ed */
514 && ((OPCODE)o->op_targ == OP_NEXTSTATE
515 || (OPCODE)o->op_targ == OP_DBSTATE))) {
520 type = (OPCODE)o->op_targ;
523 if (o->op_latefree) {
529 #ifdef DEBUG_LEAKING_SCALARS
536 Perl_op_clear(pTHX_ OP *o)
541 PERL_ARGS_ASSERT_OP_CLEAR;
544 /* if (o->op_madprop && o->op_madprop->mad_next)
546 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
547 "modification of a read only value" for a reason I can't fathom why.
548 It's the "" stringification of $_, where $_ was set to '' in a foreach
549 loop, but it defies simplification into a small test case.
550 However, commenting them out has caused ext/List/Util/t/weak.t to fail
553 mad_free(o->op_madprop);
559 switch (o->op_type) {
560 case OP_NULL: /* Was holding old type, if any. */
561 if (PL_madskills && o->op_targ != OP_NULL) {
562 o->op_type = (Optype)o->op_targ;
567 case OP_ENTEREVAL: /* Was holding hints. */
571 if (!(o->op_flags & OPf_REF)
572 || (PL_check[o->op_type] != Perl_ck_ftst))
578 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
579 /* not an OP_PADAV replacement */
580 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
585 /* It's possible during global destruction that the GV is freed
586 before the optree. Whilst the SvREFCNT_inc is happy to bump from
587 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
588 will trigger an assertion failure, because the entry to sv_clear
589 checks that the scalar is not already freed. A check of for
590 !SvIS_FREED(gv) turns out to be invalid, because during global
591 destruction the reference count can be forced down to zero
592 (with SVf_BREAK set). In which case raising to 1 and then
593 dropping to 0 triggers cleanup before it should happen. I
594 *think* that this might actually be a general, systematic,
595 weakness of the whole idea of SVf_BREAK, in that code *is*
596 allowed to raise and lower references during global destruction,
597 so any *valid* code that happens to do this during global
598 destruction might well trigger premature cleanup. */
599 bool still_valid = gv && SvREFCNT(gv);
602 SvREFCNT_inc_simple_void(gv);
604 if (cPADOPo->op_padix > 0) {
605 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
606 * may still exist on the pad */
607 pad_swipe(cPADOPo->op_padix, TRUE);
608 cPADOPo->op_padix = 0;
611 SvREFCNT_dec(cSVOPo->op_sv);
612 cSVOPo->op_sv = NULL;
615 int try_downgrade = SvREFCNT(gv) == 2;
618 gv_try_downgrade(gv);
622 case OP_METHOD_NAMED:
625 SvREFCNT_dec(cSVOPo->op_sv);
626 cSVOPo->op_sv = NULL;
629 Even if op_clear does a pad_free for the target of the op,
630 pad_free doesn't actually remove the sv that exists in the pad;
631 instead it lives on. This results in that it could be reused as
632 a target later on when the pad was reallocated.
635 pad_swipe(o->op_targ,1);
644 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
648 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
650 if (cPADOPo->op_padix > 0) {
651 pad_swipe(cPADOPo->op_padix, TRUE);
652 cPADOPo->op_padix = 0;
655 SvREFCNT_dec(cSVOPo->op_sv);
656 cSVOPo->op_sv = NULL;
660 PerlMemShared_free(cPVOPo->op_pv);
661 cPVOPo->op_pv = NULL;
665 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
669 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
670 /* No GvIN_PAD_off here, because other references may still
671 * exist on the pad */
672 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
675 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
681 forget_pmop(cPMOPo, 1);
682 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
683 /* we use the same protection as the "SAFE" version of the PM_ macros
684 * here since sv_clean_all might release some PMOPs
685 * after PL_regex_padav has been cleared
686 * and the clearing of PL_regex_padav needs to
687 * happen before sv_clean_all
690 if(PL_regex_pad) { /* We could be in destruction */
691 const IV offset = (cPMOPo)->op_pmoffset;
692 ReREFCNT_dec(PM_GETRE(cPMOPo));
693 PL_regex_pad[offset] = &PL_sv_undef;
694 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
698 ReREFCNT_dec(PM_GETRE(cPMOPo));
699 PM_SETRE(cPMOPo, NULL);
705 if (o->op_targ > 0) {
706 pad_free(o->op_targ);
712 S_cop_free(pTHX_ COP* cop)
714 PERL_ARGS_ASSERT_COP_FREE;
718 if (! specialWARN(cop->cop_warnings))
719 PerlMemShared_free(cop->cop_warnings);
720 cophh_free(CopHINTHASH_get(cop));
724 S_forget_pmop(pTHX_ PMOP *const o
730 HV * const pmstash = PmopSTASH(o);
732 PERL_ARGS_ASSERT_FORGET_PMOP;
734 if (pmstash && !SvIS_FREED(pmstash)) {
735 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
737 PMOP **const array = (PMOP**) mg->mg_ptr;
738 U32 count = mg->mg_len / sizeof(PMOP**);
743 /* Found it. Move the entry at the end to overwrite it. */
744 array[i] = array[--count];
745 mg->mg_len = count * sizeof(PMOP**);
746 /* Could realloc smaller at this point always, but probably
747 not worth it. Probably worth free()ing if we're the
750 Safefree(mg->mg_ptr);
767 S_find_and_forget_pmops(pTHX_ OP *o)
769 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
771 if (o->op_flags & OPf_KIDS) {
772 OP *kid = cUNOPo->op_first;
774 switch (kid->op_type) {
779 forget_pmop((PMOP*)kid, 0);
781 find_and_forget_pmops(kid);
782 kid = kid->op_sibling;
788 Perl_op_null(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_OP_NULL;
794 if (o->op_type == OP_NULL)
798 o->op_targ = o->op_type;
799 o->op_type = OP_NULL;
800 o->op_ppaddr = PL_ppaddr[OP_NULL];
804 Perl_op_refcnt_lock(pTHX)
812 Perl_op_refcnt_unlock(pTHX)
819 /* Contextualizers */
822 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
824 Applies a syntactic context to an op tree representing an expression.
825 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
826 or C<G_VOID> to specify the context to apply. The modified op tree
833 Perl_op_contextualize(pTHX_ OP *o, I32 context)
835 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
837 case G_SCALAR: return scalar(o);
838 case G_ARRAY: return list(o);
839 case G_VOID: return scalarvoid(o);
841 Perl_croak(aTHX_ "panic: op_contextualize bad context");
847 =head1 Optree Manipulation Functions
849 =for apidoc Am|OP*|op_linklist|OP *o
850 This function is the implementation of the L</LINKLIST> macro. It should
851 not be called directly.
857 Perl_op_linklist(pTHX_ OP *o)
861 PERL_ARGS_ASSERT_OP_LINKLIST;
866 /* establish postfix order */
867 first = cUNOPo->op_first;
870 o->op_next = LINKLIST(first);
873 if (kid->op_sibling) {
874 kid->op_next = LINKLIST(kid->op_sibling);
875 kid = kid->op_sibling;
889 S_scalarkids(pTHX_ OP *o)
891 if (o && o->op_flags & OPf_KIDS) {
893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
900 S_scalarboolean(pTHX_ OP *o)
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
907 if (ckWARN(WARN_SYNTAX)) {
908 const line_t oldline = CopLINE(PL_curcop);
910 if (PL_parser && PL_parser->copline != NOLINE)
911 CopLINE_set(PL_curcop, PL_parser->copline);
912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
913 CopLINE_set(PL_curcop, oldline);
920 Perl_scalar(pTHX_ OP *o)
925 /* assumes no premature commitment */
926 if (!o || (PL_parser && PL_parser->error_count)
927 || (o->op_flags & OPf_WANT)
928 || o->op_type == OP_RETURN)
933 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
935 switch (o->op_type) {
937 scalar(cBINOPo->op_first);
942 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
952 if (o->op_flags & OPf_KIDS) {
953 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
959 kid = cLISTOPo->op_first;
961 kid = kid->op_sibling;
964 OP *sib = kid->op_sibling;
965 if (sib && kid->op_type != OP_LEAVEWHEN) {
966 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
976 PL_curcop = &PL_compiling;
981 kid = cLISTOPo->op_first;
984 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
991 Perl_scalarvoid(pTHX_ OP *o)
995 const char* useless = NULL;
999 PERL_ARGS_ASSERT_SCALARVOID;
1001 /* trailing mad null ops don't count as "there" for void processing */
1003 o->op_type != OP_NULL &&
1005 o->op_sibling->op_type == OP_NULL)
1008 for (sib = o->op_sibling;
1009 sib && sib->op_type == OP_NULL;
1010 sib = sib->op_sibling) ;
1016 if (o->op_type == OP_NEXTSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_DBSTATE)))
1020 PL_curcop = (COP*)o; /* for warning below */
1022 /* assumes no premature commitment */
1023 want = o->op_flags & OPf_WANT;
1024 if ((want && want != OPf_WANT_SCALAR)
1025 || (PL_parser && PL_parser->error_count)
1026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1092 case OP_GETSOCKNAME:
1093 case OP_GETPEERNAME:
1098 case OP_GETPRIORITY:
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123 /* Otherwise it's "Useless use of grep iterator" */
1124 useless = OP_DESC(o);
1128 kid = cLISTOPo->op_first;
1129 if (kid && kid->op_type == OP_PUSHRE
1131 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1133 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1135 useless = OP_DESC(o);
1139 kid = cUNOPo->op_first;
1140 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1141 kid->op_type != OP_TRANS) {
1144 useless = "negative pattern binding (!~)";
1148 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1149 useless = "Non-destructive substitution (s///r)";
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1168 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169 "a constant (%"SVf")", sv));
1170 useless = SvPV_nolen(msv);
1173 useless = "a constant (undef)";
1174 if (o->op_private & OPpCONST_ARYBASE)
1176 /* don't warn on optimised away booleans, eg
1177 * use constant Foo, 5; Foo || print; */
1178 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1180 /* the constants 0 and 1 are permitted as they are
1181 conventionally used as dummies in constructs like
1182 1 while some_condition_with_side_effects; */
1183 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1185 else if (SvPOK(sv)) {
1186 /* perl4's way of mixing documentation and code
1187 (before the invention of POD) was based on a
1188 trick to mix nroff and perl code. The trick was
1189 built upon these three nroff macros being used in
1190 void context. The pink camel has the details in
1191 the script wrapman near page 319. */
1192 const char * const maybe_macro = SvPVX_const(sv);
1193 if (strnEQ(maybe_macro, "di", 2) ||
1194 strnEQ(maybe_macro, "ds", 2) ||
1195 strnEQ(maybe_macro, "ig", 2))
1200 op_null(o); /* don't execute or even remember it */
1204 o->op_type = OP_PREINC; /* pre-increment is faster */
1205 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1209 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1210 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1214 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1215 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1219 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1220 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1225 kid = cLOGOPo->op_first;
1226 if (kid->op_type == OP_NOT
1227 && (kid->op_flags & OPf_KIDS)
1229 if (o->op_type == OP_AND) {
1231 o->op_ppaddr = PL_ppaddr[OP_OR];
1233 o->op_type = OP_AND;
1234 o->op_ppaddr = PL_ppaddr[OP_AND];
1243 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1248 if (o->op_flags & OPf_STACKED)
1255 if (!(o->op_flags & OPf_KIDS))
1266 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1276 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1281 S_listkids(pTHX_ OP *o)
1283 if (o && o->op_flags & OPf_KIDS) {
1285 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1292 Perl_list(pTHX_ OP *o)
1297 /* assumes no premature commitment */
1298 if (!o || (o->op_flags & OPf_WANT)
1299 || (PL_parser && PL_parser->error_count)
1300 || o->op_type == OP_RETURN)
1305 if ((o->op_private & OPpTARGET_MY)
1306 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1308 return o; /* As if inside SASSIGN */
1311 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1313 switch (o->op_type) {
1316 list(cBINOPo->op_first);
1321 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1329 if (!(o->op_flags & OPf_KIDS))
1331 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1332 list(cBINOPo->op_first);
1333 return gen_constant_list(o);
1340 kid = cLISTOPo->op_first;
1342 kid = kid->op_sibling;
1345 OP *sib = kid->op_sibling;
1346 if (sib && kid->op_type != OP_LEAVEWHEN) {
1347 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1357 PL_curcop = &PL_compiling;
1361 kid = cLISTOPo->op_first;
1368 S_scalarseq(pTHX_ OP *o)
1372 const OPCODE type = o->op_type;
1374 if (type == OP_LINESEQ || type == OP_SCOPE ||
1375 type == OP_LEAVE || type == OP_LEAVETRY)
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1379 if (kid->op_sibling) {
1383 PL_curcop = &PL_compiling;
1385 o->op_flags &= ~OPf_PARENS;
1386 if (PL_hints & HINT_BLOCK_SCOPE)
1387 o->op_flags |= OPf_PARENS;
1390 o = newOP(OP_STUB, 0);
1395 S_modkids(pTHX_ OP *o, I32 type)
1397 if (o && o->op_flags & OPf_KIDS) {
1399 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1405 /* Propagate lvalue ("modifiable") context to an op and its children.
1406 * 'type' represents the context type, roughly based on the type of op that
1407 * would do the modifying, although local() is represented by OP_NULL.
1408 * It's responsible for detecting things that can't be modified, flag
1409 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1410 * might have to vivify a reference in $x), and so on.
1412 * For example, "$a+1 = 2" would cause mod() to be called with o being
1413 * OP_ADD and type being OP_SASSIGN, and would output an error.
1417 Perl_mod(pTHX_ OP *o, I32 type)
1421 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1424 if (!o || (PL_parser && PL_parser->error_count))
1427 if ((o->op_private & OPpTARGET_MY)
1428 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1433 switch (o->op_type) {
1439 if (!(o->op_private & OPpCONST_ARYBASE))
1442 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1443 CopARYBASE_set(&PL_compiling,
1444 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1448 SAVECOPARYBASE(&PL_compiling);
1449 CopARYBASE_set(&PL_compiling, 0);
1451 else if (type == OP_REFGEN)
1454 Perl_croak(aTHX_ "That use of $[ is unsupported");
1457 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1461 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1462 !(o->op_flags & OPf_STACKED)) {
1463 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1464 /* The default is to set op_private to the number of children,
1465 which for a UNOP such as RV2CV is always 1. And w're using
1466 the bit for a flag in RV2CV, so we need it clear. */
1467 o->op_private &= ~1;
1468 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1469 assert(cUNOPo->op_first->op_type == OP_NULL);
1470 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1473 else if (o->op_private & OPpENTERSUB_NOMOD)
1475 else { /* lvalue subroutine call */
1476 o->op_private |= OPpLVAL_INTRO;
1477 PL_modcount = RETURN_UNLIMITED_NUMBER;
1478 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1479 /* Backward compatibility mode: */
1480 o->op_private |= OPpENTERSUB_INARGS;
1483 else { /* Compile-time error message: */
1484 OP *kid = cUNOPo->op_first;
1488 if (kid->op_type != OP_PUSHMARK) {
1489 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1491 "panic: unexpected lvalue entersub "
1492 "args: type/targ %ld:%"UVuf,
1493 (long)kid->op_type, (UV)kid->op_targ);
1494 kid = kLISTOP->op_first;
1496 while (kid->op_sibling)
1497 kid = kid->op_sibling;
1498 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1500 if (kid->op_type == OP_METHOD_NAMED
1501 || kid->op_type == OP_METHOD)
1505 NewOp(1101, newop, 1, UNOP);
1506 newop->op_type = OP_RV2CV;
1507 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1508 newop->op_first = NULL;
1509 newop->op_next = (OP*)newop;
1510 kid->op_sibling = (OP*)newop;
1511 newop->op_private |= OPpLVAL_INTRO;
1512 newop->op_private &= ~1;
1516 if (kid->op_type != OP_RV2CV)
1518 "panic: unexpected lvalue entersub "
1519 "entry via type/targ %ld:%"UVuf,
1520 (long)kid->op_type, (UV)kid->op_targ);
1521 kid->op_private |= OPpLVAL_INTRO;
1522 break; /* Postpone until runtime */
1526 kid = kUNOP->op_first;
1527 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1528 kid = kUNOP->op_first;
1529 if (kid->op_type == OP_NULL)
1531 "Unexpected constant lvalue entersub "
1532 "entry via type/targ %ld:%"UVuf,
1533 (long)kid->op_type, (UV)kid->op_targ);
1534 if (kid->op_type != OP_GV) {
1535 /* Restore RV2CV to check lvalueness */
1537 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1538 okid->op_next = kid->op_next;
1539 kid->op_next = okid;
1542 okid->op_next = NULL;
1543 okid->op_type = OP_RV2CV;
1545 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1546 okid->op_private |= OPpLVAL_INTRO;
1547 okid->op_private &= ~1;
1551 cv = GvCV(kGVOP_gv);
1561 /* grep, foreach, subcalls, refgen */
1562 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1564 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1565 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1567 : (o->op_type == OP_ENTERSUB
1568 ? "non-lvalue subroutine call"
1570 type ? PL_op_desc[type] : "local"));
1584 case OP_RIGHT_SHIFT:
1593 if (!(o->op_flags & OPf_STACKED))
1600 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1606 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1607 PL_modcount = RETURN_UNLIMITED_NUMBER;
1608 return o; /* Treat \(@foo) like ordinary list. */
1612 if (scalar_mod_type(o, type))
1614 ref(cUNOPo->op_first, o->op_type);
1618 if (type == OP_LEAVESUBLV)
1619 o->op_private |= OPpMAYBE_LVSUB;
1625 PL_modcount = RETURN_UNLIMITED_NUMBER;
1628 PL_hints |= HINT_BLOCK_SCOPE;
1629 if (type == OP_LEAVESUBLV)
1630 o->op_private |= OPpMAYBE_LVSUB;
1634 ref(cUNOPo->op_first, o->op_type);
1638 PL_hints |= HINT_BLOCK_SCOPE;
1653 PL_modcount = RETURN_UNLIMITED_NUMBER;
1654 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1655 return o; /* Treat \(@foo) like ordinary list. */
1656 if (scalar_mod_type(o, type))
1658 if (type == OP_LEAVESUBLV)
1659 o->op_private |= OPpMAYBE_LVSUB;
1663 if (!type) /* local() */
1664 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1665 PAD_COMPNAME_PV(o->op_targ));
1673 if (type != OP_SASSIGN)
1677 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1682 if (type == OP_LEAVESUBLV)
1683 o->op_private |= OPpMAYBE_LVSUB;
1685 pad_free(o->op_targ);
1686 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1687 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1688 if (o->op_flags & OPf_KIDS)
1689 mod(cBINOPo->op_first->op_sibling, type);
1694 ref(cBINOPo->op_first, o->op_type);
1695 if (type == OP_ENTERSUB &&
1696 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1697 o->op_private |= OPpLVAL_DEFER;
1698 if (type == OP_LEAVESUBLV)
1699 o->op_private |= OPpMAYBE_LVSUB;
1709 if (o->op_flags & OPf_KIDS)
1710 mod(cLISTOPo->op_last, type);
1715 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1717 else if (!(o->op_flags & OPf_KIDS))
1719 if (o->op_targ != OP_LIST) {
1720 mod(cBINOPo->op_first, type);
1726 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1731 if (type != OP_LEAVESUBLV)
1733 break; /* mod()ing was handled by ck_return() */
1736 /* [20011101.069] File test operators interpret OPf_REF to mean that
1737 their argument is a filehandle; thus \stat(".") should not set
1739 if (type == OP_REFGEN &&
1740 PL_check[o->op_type] == Perl_ck_ftst)
1743 if (type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_MOD;
1746 if (type == OP_AASSIGN || type == OP_SASSIGN)
1747 o->op_flags |= OPf_SPECIAL|OPf_REF;
1748 else if (!type) { /* local() */
1751 o->op_private |= OPpLVAL_INTRO;
1752 o->op_flags &= ~OPf_SPECIAL;
1753 PL_hints |= HINT_BLOCK_SCOPE;
1758 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1759 "Useless localization of %s", OP_DESC(o));
1762 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1763 && type != OP_LEAVESUBLV)
1764 o->op_flags |= OPf_REF;
1769 S_scalar_mod_type(const OP *o, I32 type)
1771 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1775 if (o->op_type == OP_RV2GV)
1799 case OP_RIGHT_SHIFT:
1819 S_is_handle_constructor(const OP *o, I32 numargs)
1821 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1823 switch (o->op_type) {
1831 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1844 S_refkids(pTHX_ OP *o, I32 type)
1846 if (o && o->op_flags & OPf_KIDS) {
1848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1855 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1860 PERL_ARGS_ASSERT_DOREF;
1862 if (!o || (PL_parser && PL_parser->error_count))
1865 switch (o->op_type) {
1867 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1868 !(o->op_flags & OPf_STACKED)) {
1869 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1870 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1871 assert(cUNOPo->op_first->op_type == OP_NULL);
1872 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1873 o->op_flags |= OPf_SPECIAL;
1874 o->op_private &= ~1;
1879 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1880 doref(kid, type, set_op_ref);
1883 if (type == OP_DEFINED)
1884 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1885 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1888 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1889 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1890 : type == OP_RV2HV ? OPpDEREF_HV
1892 o->op_flags |= OPf_MOD;
1899 o->op_flags |= OPf_REF;
1902 if (type == OP_DEFINED)
1903 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1904 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1910 o->op_flags |= OPf_REF;
1915 if (!(o->op_flags & OPf_KIDS))
1917 doref(cBINOPo->op_first, type, set_op_ref);
1921 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1922 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1923 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1924 : type == OP_RV2HV ? OPpDEREF_HV
1926 o->op_flags |= OPf_MOD;
1936 if (!(o->op_flags & OPf_KIDS))
1938 doref(cLISTOPo->op_last, type, set_op_ref);
1948 S_dup_attrlist(pTHX_ OP *o)
1953 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1955 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1956 * where the first kid is OP_PUSHMARK and the remaining ones
1957 * are OP_CONST. We need to push the OP_CONST values.
1959 if (o->op_type == OP_CONST)
1960 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1962 else if (o->op_type == OP_NULL)
1966 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1968 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1969 if (o->op_type == OP_CONST)
1970 rop = op_append_elem(OP_LIST, rop,
1971 newSVOP(OP_CONST, o->op_flags,
1972 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1979 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1984 PERL_ARGS_ASSERT_APPLY_ATTRS;
1986 /* fake up C<use attributes $pkg,$rv,@attrs> */
1987 ENTER; /* need to protect against side-effects of 'use' */
1988 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1990 #define ATTRSMODULE "attributes"
1991 #define ATTRSMODULE_PM "attributes.pm"
1994 /* Don't force the C<use> if we don't need it. */
1995 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1996 if (svp && *svp != &PL_sv_undef)
1997 NOOP; /* already in %INC */
1999 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2000 newSVpvs(ATTRSMODULE), NULL);
2003 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2004 newSVpvs(ATTRSMODULE),
2006 op_prepend_elem(OP_LIST,
2007 newSVOP(OP_CONST, 0, stashsv),
2008 op_prepend_elem(OP_LIST,
2009 newSVOP(OP_CONST, 0,
2011 dup_attrlist(attrs))));
2017 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2020 OP *pack, *imop, *arg;
2023 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2028 assert(target->op_type == OP_PADSV ||
2029 target->op_type == OP_PADHV ||
2030 target->op_type == OP_PADAV);
2032 /* Ensure that attributes.pm is loaded. */
2033 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2035 /* Need package name for method call. */
2036 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2038 /* Build up the real arg-list. */
2039 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2041 arg = newOP(OP_PADSV, 0);
2042 arg->op_targ = target->op_targ;
2043 arg = op_prepend_elem(OP_LIST,
2044 newSVOP(OP_CONST, 0, stashsv),
2045 op_prepend_elem(OP_LIST,
2046 newUNOP(OP_REFGEN, 0,
2047 mod(arg, OP_REFGEN)),
2048 dup_attrlist(attrs)));
2050 /* Fake up a method call to import */
2051 meth = newSVpvs_share("import");
2052 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2053 op_append_elem(OP_LIST,
2054 op_prepend_elem(OP_LIST, pack, list(arg)),
2055 newSVOP(OP_METHOD_NAMED, 0, meth)));
2056 imop->op_private |= OPpENTERSUB_NOMOD;
2058 /* Combine the ops. */
2059 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2063 =notfor apidoc apply_attrs_string
2065 Attempts to apply a list of attributes specified by the C<attrstr> and
2066 C<len> arguments to the subroutine identified by the C<cv> argument which
2067 is expected to be associated with the package identified by the C<stashpv>
2068 argument (see L<attributes>). It gets this wrong, though, in that it
2069 does not correctly identify the boundaries of the individual attribute
2070 specifications within C<attrstr>. This is not really intended for the
2071 public API, but has to be listed here for systems such as AIX which
2072 need an explicit export list for symbols. (It's called from XS code
2073 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2074 to respect attribute syntax properly would be welcome.
2080 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2081 const char *attrstr, STRLEN len)
2085 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2088 len = strlen(attrstr);
2092 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2094 const char * const sstr = attrstr;
2095 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2096 attrs = op_append_elem(OP_LIST, attrs,
2097 newSVOP(OP_CONST, 0,
2098 newSVpvn(sstr, attrstr-sstr)));
2102 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2103 newSVpvs(ATTRSMODULE),
2104 NULL, op_prepend_elem(OP_LIST,
2105 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2106 op_prepend_elem(OP_LIST,
2107 newSVOP(OP_CONST, 0,
2108 newRV(MUTABLE_SV(cv))),
2113 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2118 PERL_ARGS_ASSERT_MY_KID;
2120 if (!o || (PL_parser && PL_parser->error_count))
2124 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2125 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2129 if (type == OP_LIST) {
2131 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2132 my_kid(kid, attrs, imopsp);
2133 } else if (type == OP_UNDEF
2139 } else if (type == OP_RV2SV || /* "our" declaration */
2141 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2142 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2143 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2145 PL_parser->in_my == KEY_our
2147 : PL_parser->in_my == KEY_state ? "state" : "my"));
2149 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2150 PL_parser->in_my = FALSE;
2151 PL_parser->in_my_stash = NULL;
2152 apply_attrs(GvSTASH(gv),
2153 (type == OP_RV2SV ? GvSV(gv) :
2154 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2155 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2158 o->op_private |= OPpOUR_INTRO;
2161 else if (type != OP_PADSV &&
2164 type != OP_PUSHMARK)
2166 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2168 PL_parser->in_my == KEY_our
2170 : PL_parser->in_my == KEY_state ? "state" : "my"));
2173 else if (attrs && type != OP_PUSHMARK) {
2176 PL_parser->in_my = FALSE;
2177 PL_parser->in_my_stash = NULL;
2179 /* check for C<my Dog $spot> when deciding package */
2180 stash = PAD_COMPNAME_TYPE(o->op_targ);
2182 stash = PL_curstash;
2183 apply_attrs_my(stash, o, attrs, imopsp);
2185 o->op_flags |= OPf_MOD;
2186 o->op_private |= OPpLVAL_INTRO;
2187 if (PL_parser->in_my == KEY_state)
2188 o->op_private |= OPpPAD_STATE;
2193 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2197 int maybe_scalar = 0;
2199 PERL_ARGS_ASSERT_MY_ATTRS;
2201 /* [perl #17376]: this appears to be premature, and results in code such as
2202 C< our(%x); > executing in list mode rather than void mode */
2204 if (o->op_flags & OPf_PARENS)
2214 o = my_kid(o, attrs, &rops);
2216 if (maybe_scalar && o->op_type == OP_PADSV) {
2217 o = scalar(op_append_list(OP_LIST, rops, o));
2218 o->op_private |= OPpLVAL_INTRO;
2221 o = op_append_list(OP_LIST, o, rops);
2223 PL_parser->in_my = FALSE;
2224 PL_parser->in_my_stash = NULL;
2229 Perl_sawparens(pTHX_ OP *o)
2231 PERL_UNUSED_CONTEXT;
2233 o->op_flags |= OPf_PARENS;
2238 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2242 const OPCODE ltype = left->op_type;
2243 const OPCODE rtype = right->op_type;
2245 PERL_ARGS_ASSERT_BIND_MATCH;
2247 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2248 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2250 const char * const desc
2251 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2252 ? (int)rtype : OP_MATCH];
2253 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2254 ? "@array" : "%hash");
2255 Perl_warner(aTHX_ packWARN(WARN_MISC),
2256 "Applying %s to %s will act on scalar(%s)",
2257 desc, sample, sample);
2260 if (rtype == OP_CONST &&
2261 cSVOPx(right)->op_private & OPpCONST_BARE &&
2262 cSVOPx(right)->op_private & OPpCONST_STRICT)
2264 no_bareword_allowed(right);
2267 /* !~ doesn't make sense with s///r, so error on it for now */
2268 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2270 yyerror("Using !~ with s///r doesn't make sense");
2272 ismatchop = (rtype == OP_MATCH ||
2273 rtype == OP_SUBST ||
2275 && !(right->op_flags & OPf_SPECIAL);
2276 if (ismatchop && right->op_private & OPpTARGET_MY) {
2278 right->op_private &= ~OPpTARGET_MY;
2280 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2283 right->op_flags |= OPf_STACKED;
2284 if (rtype != OP_MATCH &&
2285 ! (rtype == OP_TRANS &&
2286 right->op_private & OPpTRANS_IDENTICAL) &&
2287 ! (rtype == OP_SUBST &&
2288 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2289 newleft = mod(left, rtype);
2292 if (right->op_type == OP_TRANS)
2293 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2295 o = op_prepend_elem(rtype, scalar(newleft), right);
2297 return newUNOP(OP_NOT, 0, scalar(o));
2301 return bind_match(type, left,
2302 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2306 Perl_invert(pTHX_ OP *o)
2310 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2314 Perl_scope(pTHX_ OP *o)
2318 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2319 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2320 o->op_type = OP_LEAVE;
2321 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2323 else if (o->op_type == OP_LINESEQ) {
2325 o->op_type = OP_SCOPE;
2326 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2327 kid = ((LISTOP*)o)->op_first;
2328 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2331 /* The following deals with things like 'do {1 for 1}' */
2332 kid = kid->op_sibling;
2334 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2339 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2345 Perl_block_start(pTHX_ int full)
2348 const int retval = PL_savestack_ix;
2350 pad_block_start(full);
2352 PL_hints &= ~HINT_BLOCK_SCOPE;
2353 SAVECOMPILEWARNINGS();
2354 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2356 CALL_BLOCK_HOOKS(bhk_start, full);
2362 Perl_block_end(pTHX_ I32 floor, OP *seq)
2365 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2366 OP* retval = scalarseq(seq);
2368 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2371 CopHINTS_set(&PL_compiling, PL_hints);
2373 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2376 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2382 =head1 Compile-time scope hooks
2384 =for apidoc Ao||blockhook_register
2386 Register a set of hooks to be called when the Perl lexical scope changes
2387 at compile time. See L<perlguts/"Compile-time scope hooks">.
2393 Perl_blockhook_register(pTHX_ BHK *hk)
2395 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2397 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2404 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2405 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2406 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2409 OP * const o = newOP(OP_PADSV, 0);
2410 o->op_targ = offset;
2416 Perl_newPROG(pTHX_ OP *o)
2420 PERL_ARGS_ASSERT_NEWPROG;
2425 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2426 ((PL_in_eval & EVAL_KEEPERR)
2427 ? OPf_SPECIAL : 0), o);
2428 /* don't use LINKLIST, since PL_eval_root might indirect through
2429 * a rather expensive function call and LINKLIST evaluates its
2430 * argument more than once */
2431 PL_eval_start = op_linklist(PL_eval_root);
2432 PL_eval_root->op_private |= OPpREFCOUNTED;
2433 OpREFCNT_set(PL_eval_root, 1);
2434 PL_eval_root->op_next = 0;
2435 CALL_PEEP(PL_eval_start);
2438 if (o->op_type == OP_STUB) {
2439 PL_comppad_name = 0;
2441 S_op_destroy(aTHX_ o);
2444 PL_main_root = scope(sawparens(scalarvoid(o)));
2445 PL_curcop = &PL_compiling;
2446 PL_main_start = LINKLIST(PL_main_root);
2447 PL_main_root->op_private |= OPpREFCOUNTED;
2448 OpREFCNT_set(PL_main_root, 1);
2449 PL_main_root->op_next = 0;
2450 CALL_PEEP(PL_main_start);
2453 /* Register with debugger */
2455 CV * const cv = get_cvs("DB::postponed", 0);
2459 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2461 call_sv(MUTABLE_SV(cv), G_DISCARD);
2468 Perl_localize(pTHX_ OP *o, I32 lex)
2472 PERL_ARGS_ASSERT_LOCALIZE;
2474 if (o->op_flags & OPf_PARENS)
2475 /* [perl #17376]: this appears to be premature, and results in code such as
2476 C< our(%x); > executing in list mode rather than void mode */
2483 if ( PL_parser->bufptr > PL_parser->oldbufptr
2484 && PL_parser->bufptr[-1] == ','
2485 && ckWARN(WARN_PARENTHESIS))
2487 char *s = PL_parser->bufptr;
2490 /* some heuristics to detect a potential error */
2491 while (*s && (strchr(", \t\n", *s)))
2495 if (*s && strchr("@$%*", *s) && *++s
2496 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2499 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2501 while (*s && (strchr(", \t\n", *s)))
2507 if (sigil && (*s == ';' || *s == '=')) {
2508 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2509 "Parentheses missing around \"%s\" list",
2511 ? (PL_parser->in_my == KEY_our
2513 : PL_parser->in_my == KEY_state
2523 o = mod(o, OP_NULL); /* a bit kludgey */
2524 PL_parser->in_my = FALSE;
2525 PL_parser->in_my_stash = NULL;
2530 Perl_jmaybe(pTHX_ OP *o)
2532 PERL_ARGS_ASSERT_JMAYBE;
2534 if (o->op_type == OP_LIST) {
2536 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2537 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2543 S_fold_constants(pTHX_ register OP *o)
2546 register OP * VOL curop;
2548 VOL I32 type = o->op_type;
2553 SV * const oldwarnhook = PL_warnhook;
2554 SV * const olddiehook = PL_diehook;
2558 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2560 if (PL_opargs[type] & OA_RETSCALAR)
2562 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2563 o->op_targ = pad_alloc(type, SVs_PADTMP);
2565 /* integerize op, unless it happens to be C<-foo>.
2566 * XXX should pp_i_negate() do magic string negation instead? */
2567 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2568 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2569 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2571 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2574 if (!(PL_opargs[type] & OA_FOLDCONST))
2579 /* XXX might want a ck_negate() for this */
2580 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2591 /* XXX what about the numeric ops? */
2592 if (PL_hints & HINT_LOCALE)
2597 if (PL_parser && PL_parser->error_count)
2598 goto nope; /* Don't try to run w/ errors */
2600 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2601 const OPCODE type = curop->op_type;
2602 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2604 type != OP_SCALAR &&
2606 type != OP_PUSHMARK)
2612 curop = LINKLIST(o);
2613 old_next = o->op_next;
2617 oldscope = PL_scopestack_ix;
2618 create_eval_scope(G_FAKINGEVAL);
2620 /* Verify that we don't need to save it: */
2621 assert(PL_curcop == &PL_compiling);
2622 StructCopy(&PL_compiling, ¬_compiling, COP);
2623 PL_curcop = ¬_compiling;
2624 /* The above ensures that we run with all the correct hints of the
2625 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2626 assert(IN_PERL_RUNTIME);
2627 PL_warnhook = PERL_WARNHOOK_FATAL;
2634 sv = *(PL_stack_sp--);
2635 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2636 pad_swipe(o->op_targ, FALSE);
2637 else if (SvTEMP(sv)) { /* grab mortal temp? */
2638 SvREFCNT_inc_simple_void(sv);
2643 /* Something tried to die. Abandon constant folding. */
2644 /* Pretend the error never happened. */
2646 o->op_next = old_next;
2650 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2651 PL_warnhook = oldwarnhook;
2652 PL_diehook = olddiehook;
2653 /* XXX note that this croak may fail as we've already blown away
2654 * the stack - eg any nested evals */
2655 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2658 PL_warnhook = oldwarnhook;
2659 PL_diehook = olddiehook;
2660 PL_curcop = &PL_compiling;
2662 if (PL_scopestack_ix > oldscope)
2663 delete_eval_scope();
2672 if (type == OP_RV2GV)
2673 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2675 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2676 op_getmad(o,newop,'f');
2684 S_gen_constant_list(pTHX_ register OP *o)
2688 const I32 oldtmps_floor = PL_tmps_floor;
2691 if (PL_parser && PL_parser->error_count)
2692 return o; /* Don't attempt to run with errors */
2694 PL_op = curop = LINKLIST(o);
2700 assert (!(curop->op_flags & OPf_SPECIAL));
2701 assert(curop->op_type == OP_RANGE);
2703 PL_tmps_floor = oldtmps_floor;
2705 o->op_type = OP_RV2AV;
2706 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2707 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2708 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2709 o->op_opt = 0; /* needs to be revisited in rpeep() */
2710 curop = ((UNOP*)o)->op_first;
2711 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2713 op_getmad(curop,o,'O');
2722 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2725 if (!o || o->op_type != OP_LIST)
2726 o = newLISTOP(OP_LIST, 0, o, NULL);
2728 o->op_flags &= ~OPf_WANT;
2730 if (!(PL_opargs[type] & OA_MARK))
2731 op_null(cLISTOPo->op_first);
2733 o->op_type = (OPCODE)type;
2734 o->op_ppaddr = PL_ppaddr[type];
2735 o->op_flags |= flags;
2737 o = CHECKOP(type, o);
2738 if (o->op_type != (unsigned)type)
2741 return fold_constants(o);
2745 =head1 Optree Manipulation Functions
2748 /* List constructors */
2751 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2753 Append an item to the list of ops contained directly within a list-type
2754 op, returning the lengthened list. I<first> is the list-type op,
2755 and I<last> is the op to append to the list. I<optype> specifies the
2756 intended opcode for the list. If I<first> is not already a list of the
2757 right type, it will be upgraded into one. If either I<first> or I<last>
2758 is null, the other is returned unchanged.
2764 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2772 if (first->op_type != (unsigned)type
2773 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2775 return newLISTOP(type, 0, first, last);
2778 if (first->op_flags & OPf_KIDS)
2779 ((LISTOP*)first)->op_last->op_sibling = last;
2781 first->op_flags |= OPf_KIDS;
2782 ((LISTOP*)first)->op_first = last;
2784 ((LISTOP*)first)->op_last = last;
2789 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2791 Concatenate the lists of ops contained directly within two list-type ops,
2792 returning the combined list. I<first> and I<last> are the list-type ops
2793 to concatenate. I<optype> specifies the intended opcode for the list.
2794 If either I<first> or I<last> is not already a list of the right type,
2795 it will be upgraded into one. If either I<first> or I<last> is null,
2796 the other is returned unchanged.
2802 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2810 if (first->op_type != (unsigned)type)
2811 return op_prepend_elem(type, first, last);
2813 if (last->op_type != (unsigned)type)
2814 return op_append_elem(type, first, last);
2816 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2817 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2818 first->op_flags |= (last->op_flags & OPf_KIDS);
2821 if (((LISTOP*)last)->op_first && first->op_madprop) {
2822 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2824 while (mp->mad_next)
2826 mp->mad_next = first->op_madprop;
2829 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2832 first->op_madprop = last->op_madprop;
2833 last->op_madprop = 0;
2836 S_op_destroy(aTHX_ last);
2842 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2844 Prepend an item to the list of ops contained directly within a list-type
2845 op, returning the lengthened list. I<first> is the op to prepend to the
2846 list, and I<last> is the list-type op. I<optype> specifies the intended
2847 opcode for the list. If I<last> is not already a list of the right type,
2848 it will be upgraded into one. If either I<first> or I<last> is null,
2849 the other is returned unchanged.
2855 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2863 if (last->op_type == (unsigned)type) {
2864 if (type == OP_LIST) { /* already a PUSHMARK there */
2865 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2866 ((LISTOP*)last)->op_first->op_sibling = first;
2867 if (!(first->op_flags & OPf_PARENS))
2868 last->op_flags &= ~OPf_PARENS;
2871 if (!(last->op_flags & OPf_KIDS)) {
2872 ((LISTOP*)last)->op_last = first;
2873 last->op_flags |= OPf_KIDS;
2875 first->op_sibling = ((LISTOP*)last)->op_first;
2876 ((LISTOP*)last)->op_first = first;
2878 last->op_flags |= OPf_KIDS;
2882 return newLISTOP(type, 0, first, last);
2890 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2893 Newxz(tk, 1, TOKEN);
2894 tk->tk_type = (OPCODE)optype;
2895 tk->tk_type = 12345;
2897 tk->tk_mad = madprop;
2902 Perl_token_free(pTHX_ TOKEN* tk)
2904 PERL_ARGS_ASSERT_TOKEN_FREE;
2906 if (tk->tk_type != 12345)
2908 mad_free(tk->tk_mad);
2913 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2918 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2920 if (tk->tk_type != 12345) {
2921 Perl_warner(aTHX_ packWARN(WARN_MISC),
2922 "Invalid TOKEN object ignored");
2929 /* faked up qw list? */
2931 tm->mad_type == MAD_SV &&
2932 SvPVX((SV *)tm->mad_val)[0] == 'q')
2939 /* pretend constant fold didn't happen? */
2940 if (mp->mad_key == 'f' &&
2941 (o->op_type == OP_CONST ||
2942 o->op_type == OP_GV) )
2944 token_getmad(tk,(OP*)mp->mad_val,slot);
2958 if (mp->mad_key == 'X')
2959 mp->mad_key = slot; /* just change the first one */
2969 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2978 /* pretend constant fold didn't happen? */
2979 if (mp->mad_key == 'f' &&
2980 (o->op_type == OP_CONST ||
2981 o->op_type == OP_GV) )
2983 op_getmad(from,(OP*)mp->mad_val,slot);
2990 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2993 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2999 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3008 /* pretend constant fold didn't happen? */
3009 if (mp->mad_key == 'f' &&
3010 (o->op_type == OP_CONST ||
3011 o->op_type == OP_GV) )
3013 op_getmad(from,(OP*)mp->mad_val,slot);
3020 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3023 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3027 PerlIO_printf(PerlIO_stderr(),
3028 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3034 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3052 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3056 addmad(tm, &(o->op_madprop), slot);
3060 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3081 Perl_newMADsv(pTHX_ char key, SV* sv)
3083 PERL_ARGS_ASSERT_NEWMADSV;
3085 return newMADPROP(key, MAD_SV, sv, 0);
3089 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3092 Newxz(mp, 1, MADPROP);
3095 mp->mad_vlen = vlen;
3096 mp->mad_type = type;
3098 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3103 Perl_mad_free(pTHX_ MADPROP* mp)
3105 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3109 mad_free(mp->mad_next);
3110 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3111 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3112 switch (mp->mad_type) {
3116 Safefree((char*)mp->mad_val);
3119 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3120 op_free((OP*)mp->mad_val);
3123 sv_free(MUTABLE_SV(mp->mad_val));
3126 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3135 =head1 Optree construction
3137 =for apidoc Am|OP *|newNULLLIST
3139 Constructs, checks, and returns a new C<stub> op, which represents an
3140 empty list expression.
3146 Perl_newNULLLIST(pTHX)
3148 return newOP(OP_STUB, 0);
3152 S_force_list(pTHX_ OP *o)
3154 if (!o || o->op_type != OP_LIST)
3155 o = newLISTOP(OP_LIST, 0, o, NULL);
3161 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3163 Constructs, checks, and returns an op of any list type. I<type> is
3164 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3165 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3166 supply up to two ops to be direct children of the list op; they are
3167 consumed by this function and become part of the constructed op tree.
3173 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3178 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3180 NewOp(1101, listop, 1, LISTOP);
3182 listop->op_type = (OPCODE)type;
3183 listop->op_ppaddr = PL_ppaddr[type];
3186 listop->op_flags = (U8)flags;
3190 else if (!first && last)
3193 first->op_sibling = last;
3194 listop->op_first = first;
3195 listop->op_last = last;
3196 if (type == OP_LIST) {
3197 OP* const pushop = newOP(OP_PUSHMARK, 0);
3198 pushop->op_sibling = first;
3199 listop->op_first = pushop;
3200 listop->op_flags |= OPf_KIDS;
3202 listop->op_last = pushop;
3205 return CHECKOP(type, listop);
3209 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3211 Constructs, checks, and returns an op of any base type (any type that
3212 has no extra fields). I<type> is the opcode. I<flags> gives the
3213 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3220 Perl_newOP(pTHX_ I32 type, I32 flags)
3225 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3226 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3227 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3228 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3230 NewOp(1101, o, 1, OP);
3231 o->op_type = (OPCODE)type;
3232 o->op_ppaddr = PL_ppaddr[type];
3233 o->op_flags = (U8)flags;
3235 o->op_latefreed = 0;
3239 o->op_private = (U8)(0 | (flags >> 8));
3240 if (PL_opargs[type] & OA_RETSCALAR)
3242 if (PL_opargs[type] & OA_TARGET)
3243 o->op_targ = pad_alloc(type, SVs_PADTMP);
3244 return CHECKOP(type, o);
3248 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3250 Constructs, checks, and returns an op of any unary type. I<type> is
3251 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3252 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3253 bits, the eight bits of C<op_private>, except that the bit with value 1
3254 is automatically set. I<first> supplies an optional op to be the direct
3255 child of the unary op; it is consumed by this function and become part
3256 of the constructed op tree.
3262 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3267 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3269 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3270 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3271 || type == OP_SASSIGN
3272 || type == OP_ENTERTRY
3273 || type == OP_NULL );
3276 first = newOP(OP_STUB, 0);
3277 if (PL_opargs[type] & OA_MARK)
3278 first = force_list(first);
3280 NewOp(1101, unop, 1, UNOP);
3281 unop->op_type = (OPCODE)type;
3282 unop->op_ppaddr = PL_ppaddr[type];
3283 unop->op_first = first;
3284 unop->op_flags = (U8)(flags | OPf_KIDS);
3285 unop->op_private = (U8)(1 | (flags >> 8));
3286 unop = (UNOP*) CHECKOP(type, unop);
3290 return fold_constants((OP *) unop);
3294 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3296 Constructs, checks, and returns an op of any binary type. I<type>
3297 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3298 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3299 the eight bits of C<op_private>, except that the bit with value 1 or
3300 2 is automatically set as required. I<first> and I<last> supply up to
3301 two ops to be the direct children of the binary op; they are consumed
3302 by this function and become part of the constructed op tree.
3308 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3313 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3314 || type == OP_SASSIGN || type == OP_NULL );
3316 NewOp(1101, binop, 1, BINOP);
3319 first = newOP(OP_NULL, 0);
3321 binop->op_type = (OPCODE)type;
3322 binop->op_ppaddr = PL_ppaddr[type];
3323 binop->op_first = first;
3324 binop->op_flags = (U8)(flags | OPf_KIDS);
3327 binop->op_private = (U8)(1 | (flags >> 8));
3330 binop->op_private = (U8)(2 | (flags >> 8));
3331 first->op_sibling = last;
3334 binop = (BINOP*)CHECKOP(type, binop);
3335 if (binop->op_next || binop->op_type != (OPCODE)type)
3338 binop->op_last = binop->op_first->op_sibling;
3340 return fold_constants((OP *)binop);
3343 static int uvcompare(const void *a, const void *b)
3344 __attribute__nonnull__(1)
3345 __attribute__nonnull__(2)
3346 __attribute__pure__;
3347 static int uvcompare(const void *a, const void *b)
3349 if (*((const UV *)a) < (*(const UV *)b))
3351 if (*((const UV *)a) > (*(const UV *)b))
3353 if (*((const UV *)a+1) < (*(const UV *)b+1))
3355 if (*((const UV *)a+1) > (*(const UV *)b+1))
3361 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3364 SV * const tstr = ((SVOP*)expr)->op_sv;
3367 (repl->op_type == OP_NULL)
3368 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3370 ((SVOP*)repl)->op_sv;
3373 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3374 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3378 register short *tbl;
3380 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3381 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3382 I32 del = o->op_private & OPpTRANS_DELETE;
3385 PERL_ARGS_ASSERT_PMTRANS;
3387 PL_hints |= HINT_BLOCK_SCOPE;
3390 o->op_private |= OPpTRANS_FROM_UTF;
3393 o->op_private |= OPpTRANS_TO_UTF;
3395 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3396 SV* const listsv = newSVpvs("# comment\n");
3398 const U8* tend = t + tlen;
3399 const U8* rend = r + rlen;
3413 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3414 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3417 const U32 flags = UTF8_ALLOW_DEFAULT;
3421 t = tsave = bytes_to_utf8(t, &len);
3424 if (!to_utf && rlen) {
3426 r = rsave = bytes_to_utf8(r, &len);
3430 /* There are several snags with this code on EBCDIC:
3431 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3432 2. scan_const() in toke.c has encoded chars in native encoding which makes
3433 ranges at least in EBCDIC 0..255 range the bottom odd.
3437 U8 tmpbuf[UTF8_MAXBYTES+1];
3440 Newx(cp, 2*tlen, UV);
3442 transv = newSVpvs("");
3444 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3446 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3448 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3452 cp[2*i+1] = cp[2*i];
3456 qsort(cp, i, 2*sizeof(UV), uvcompare);
3457 for (j = 0; j < i; j++) {
3459 diff = val - nextmin;
3461 t = uvuni_to_utf8(tmpbuf,nextmin);
3462 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3464 U8 range_mark = UTF_TO_NATIVE(0xff);
3465 t = uvuni_to_utf8(tmpbuf, val - 1);
3466 sv_catpvn(transv, (char *)&range_mark, 1);
3467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3474 t = uvuni_to_utf8(tmpbuf,nextmin);
3475 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3477 U8 range_mark = UTF_TO_NATIVE(0xff);
3478 sv_catpvn(transv, (char *)&range_mark, 1);
3480 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3481 UNICODE_ALLOW_SUPER);
3482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3483 t = (const U8*)SvPVX_const(transv);
3484 tlen = SvCUR(transv);
3488 else if (!rlen && !del) {
3489 r = t; rlen = tlen; rend = tend;
3492 if ((!rlen && !del) || t == r ||
3493 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3495 o->op_private |= OPpTRANS_IDENTICAL;
3499 while (t < tend || tfirst <= tlast) {
3500 /* see if we need more "t" chars */
3501 if (tfirst > tlast) {
3502 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3504 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3506 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3513 /* now see if we need more "r" chars */
3514 if (rfirst > rlast) {
3516 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3518 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3520 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3529 rfirst = rlast = 0xffffffff;
3533 /* now see which range will peter our first, if either. */
3534 tdiff = tlast - tfirst;
3535 rdiff = rlast - rfirst;
3542 if (rfirst == 0xffffffff) {
3543 diff = tdiff; /* oops, pretend rdiff is infinite */
3545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3546 (long)tfirst, (long)tlast);
3548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3553 (long)tfirst, (long)(tfirst + diff),
3556 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3557 (long)tfirst, (long)rfirst);
3559 if (rfirst + diff > max)
3560 max = rfirst + diff;
3562 grows = (tfirst < rfirst &&
3563 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3575 else if (max > 0xff)
3580 PerlMemShared_free(cPVOPo->op_pv);
3581 cPVOPo->op_pv = NULL;
3583 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3585 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3586 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3587 PAD_SETSV(cPADOPo->op_padix, swash);
3589 SvREADONLY_on(swash);
3591 cSVOPo->op_sv = swash;
3593 SvREFCNT_dec(listsv);
3594 SvREFCNT_dec(transv);
3596 if (!del && havefinal && rlen)
3597 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3598 newSVuv((UV)final), 0);
3601 o->op_private |= OPpTRANS_GROWS;
3607 op_getmad(expr,o,'e');
3608 op_getmad(repl,o,'r');
3616 tbl = (short*)cPVOPo->op_pv;
3618 Zero(tbl, 256, short);
3619 for (i = 0; i < (I32)tlen; i++)
3621 for (i = 0, j = 0; i < 256; i++) {
3623 if (j >= (I32)rlen) {
3632 if (i < 128 && r[j] >= 128)
3642 o->op_private |= OPpTRANS_IDENTICAL;
3644 else if (j >= (I32)rlen)
3649 PerlMemShared_realloc(tbl,
3650 (0x101+rlen-j) * sizeof(short));
3651 cPVOPo->op_pv = (char*)tbl;
3653 tbl[0x100] = (short)(rlen - j);
3654 for (i=0; i < (I32)rlen - j; i++)
3655 tbl[0x101+i] = r[j+i];
3659 if (!rlen && !del) {
3662 o->op_private |= OPpTRANS_IDENTICAL;
3664 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3665 o->op_private |= OPpTRANS_IDENTICAL;
3667 for (i = 0; i < 256; i++)
3669 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3670 if (j >= (I32)rlen) {
3672 if (tbl[t[i]] == -1)
3678 if (tbl[t[i]] == -1) {
3679 if (t[i] < 128 && r[j] >= 128)
3686 if(del && rlen == tlen) {
3687 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3688 } else if(rlen > tlen) {
3689 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3693 o->op_private |= OPpTRANS_GROWS;
3695 op_getmad(expr,o,'e');
3696 op_getmad(repl,o,'r');
3706 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3708 Constructs, checks, and returns an op of any pattern matching type.
3709 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3710 and, shifted up eight bits, the eight bits of C<op_private>.
3716 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3723 NewOp(1101, pmop, 1, PMOP);
3724 pmop->op_type = (OPCODE)type;
3725 pmop->op_ppaddr = PL_ppaddr[type];
3726 pmop->op_flags = (U8)flags;
3727 pmop->op_private = (U8)(0 | (flags >> 8));
3729 if (PL_hints & HINT_RE_TAINT)
3730 pmop->op_pmflags |= PMf_RETAINT;
3731 if (PL_hints & HINT_LOCALE) {
3732 pmop->op_pmflags |= PMf_LOCALE;
3734 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3735 pmop->op_pmflags |= RXf_PMf_UNICODE;
3737 if (PL_hints & HINT_RE_FLAGS) {
3738 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3739 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3741 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3742 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3743 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3745 if (reflags && SvOK(reflags)) {
3746 pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3747 pmop->op_pmflags |= SvIV(reflags);
3753 assert(SvPOK(PL_regex_pad[0]));
3754 if (SvCUR(PL_regex_pad[0])) {
3755 /* Pop off the "packed" IV from the end. */
3756 SV *const repointer_list = PL_regex_pad[0];
3757 const char *p = SvEND(repointer_list) - sizeof(IV);
3758 const IV offset = *((IV*)p);
3760 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3762 SvEND_set(repointer_list, p);
3764 pmop->op_pmoffset = offset;
3765 /* This slot should be free, so assert this: */
3766 assert(PL_regex_pad[offset] == &PL_sv_undef);
3768 SV * const repointer = &PL_sv_undef;
3769 av_push(PL_regex_padav, repointer);
3770 pmop->op_pmoffset = av_len(PL_regex_padav);
3771 PL_regex_pad = AvARRAY(PL_regex_padav);
3775 return CHECKOP(type, pmop);
3778 /* Given some sort of match op o, and an expression expr containing a
3779 * pattern, either compile expr into a regex and attach it to o (if it's
3780 * constant), or convert expr into a runtime regcomp op sequence (if it's
3783 * isreg indicates that the pattern is part of a regex construct, eg
3784 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3785 * split "pattern", which aren't. In the former case, expr will be a list
3786 * if the pattern contains more than one term (eg /a$b/) or if it contains
3787 * a replacement, ie s/// or tr///.
3791 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3796 I32 repl_has_vars = 0;
3800 PERL_ARGS_ASSERT_PMRUNTIME;
3802 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3803 /* last element in list is the replacement; pop it */
3805 repl = cLISTOPx(expr)->op_last;
3806 kid = cLISTOPx(expr)->op_first;
3807 while (kid->op_sibling != repl)
3808 kid = kid->op_sibling;
3809 kid->op_sibling = NULL;
3810 cLISTOPx(expr)->op_last = kid;
3813 if (isreg && expr->op_type == OP_LIST &&
3814 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3816 /* convert single element list to element */
3817 OP* const oe = expr;
3818 expr = cLISTOPx(oe)->op_first->op_sibling;
3819 cLISTOPx(oe)->op_first->op_sibling = NULL;
3820 cLISTOPx(oe)->op_last = NULL;
3824 if (o->op_type == OP_TRANS) {
3825 return pmtrans(o, expr, repl);
3828 reglist = isreg && expr->op_type == OP_LIST;
3832 PL_hints |= HINT_BLOCK_SCOPE;
3835 if (expr->op_type == OP_CONST) {
3836 SV *pat = ((SVOP*)expr)->op_sv;
3837 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3839 if (o->op_flags & OPf_SPECIAL)
3840 pm_flags |= RXf_SPLIT;
3843 assert (SvUTF8(pat));
3844 } else if (SvUTF8(pat)) {
3845 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3846 trapped in use 'bytes'? */
3847 /* Make a copy of the octet sequence, but without the flag on, as
3848 the compiler now honours the SvUTF8 flag on pat. */
3850 const char *const p = SvPV(pat, len);
3851 pat = newSVpvn_flags(p, len, SVs_TEMP);
3854 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3857 op_getmad(expr,(OP*)pm,'e');
3863 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3864 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3866 : OP_REGCMAYBE),0,expr);
3868 NewOp(1101, rcop, 1, LOGOP);
3869 rcop->op_type = OP_REGCOMP;
3870 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3871 rcop->op_first = scalar(expr);
3872 rcop->op_flags |= OPf_KIDS
3873 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3874 | (reglist ? OPf_STACKED : 0);
3875 rcop->op_private = 1;
3878 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3880 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3883 /* establish postfix order */
3884 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3886 rcop->op_next = expr;
3887 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3890 rcop->op_next = LINKLIST(expr);
3891 expr->op_next = (OP*)rcop;
3894 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3899 if (pm->op_pmflags & PMf_EVAL) {
3901 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3902 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3904 else if (repl->op_type == OP_CONST)
3908 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3909 if (curop->op_type == OP_SCOPE
3910 || curop->op_type == OP_LEAVE
3911 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3912 if (curop->op_type == OP_GV) {
3913 GV * const gv = cGVOPx_gv(curop);
3915 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3918 else if (curop->op_type == OP_RV2CV)
3920 else if (curop->op_type == OP_RV2SV ||
3921 curop->op_type == OP_RV2AV ||
3922 curop->op_type == OP_RV2HV ||
3923 curop->op_type == OP_RV2GV) {
3924 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3927 else if (curop->op_type == OP_PADSV ||
3928 curop->op_type == OP_PADAV ||
3929 curop->op_type == OP_PADHV ||
3930 curop->op_type == OP_PADANY)
3934 else if (curop->op_type == OP_PUSHRE)
3935 NOOP; /* Okay here, dangerous in newASSIGNOP */
3945 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3947 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3948 op_prepend_elem(o->op_type, scalar(repl), o);
3951 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3952 pm->op_pmflags |= PMf_MAYBE_CONST;
3954 NewOp(1101, rcop, 1, LOGOP);
3955 rcop->op_type = OP_SUBSTCONT;
3956 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3957 rcop->op_first = scalar(repl);
3958 rcop->op_flags |= OPf_KIDS;
3959 rcop->op_private = 1;
3962 /* establish postfix order */
3963 rcop->op_next = LINKLIST(repl);
3964 repl->op_next = (OP*)rcop;
3966 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3967 assert(!(pm->op_pmflags & PMf_ONCE));
3968 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3977 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3979 Constructs, checks, and returns an op of any type that involves an
3980 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
3981 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
3982 takes ownership of one reference to it.
3988 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3993 PERL_ARGS_ASSERT_NEWSVOP;
3995 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3996 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3997 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3999 NewOp(1101, svop, 1, SVOP);
4000 svop->op_type = (OPCODE)type;
4001 svop->op_ppaddr = PL_ppaddr[type];
4003 svop->op_next = (OP*)svop;
4004 svop->op_flags = (U8)flags;
4005 if (PL_opargs[type] & OA_RETSCALAR)
4007 if (PL_opargs[type] & OA_TARGET)
4008 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4009 return CHECKOP(type, svop);
4015 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4017 Constructs, checks, and returns an op of any type that involves a
4018 reference to a pad element. I<type> is the opcode. I<flags> gives the
4019 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4020 is populated with I<sv>; this function takes ownership of one reference
4023 This function only exists if Perl has been compiled to use ithreads.
4029 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4034 PERL_ARGS_ASSERT_NEWPADOP;
4036 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4037 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4038 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4040 NewOp(1101, padop, 1, PADOP);
4041 padop->op_type = (OPCODE)type;
4042 padop->op_ppaddr = PL_ppaddr[type];
4043 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4044 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4045 PAD_SETSV(padop->op_padix, sv);
4048 padop->op_next = (OP*)padop;
4049 padop->op_flags = (U8)flags;
4050 if (PL_opargs[type] & OA_RETSCALAR)
4052 if (PL_opargs[type] & OA_TARGET)
4053 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4054 return CHECKOP(type, padop);
4057 #endif /* !USE_ITHREADS */
4060 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4062 Constructs, checks, and returns an op of any type that involves an
4063 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4064 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4065 reference; calling this function does not transfer ownership of any
4072 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4076 PERL_ARGS_ASSERT_NEWGVOP;
4080 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4082 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4087 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4089 Constructs, checks, and returns an op of any type that involves an
4090 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4091 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4092 must have been allocated using L</PerlMemShared_malloc>; the memory will
4093 be freed when the op is destroyed.
4099 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4104 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4105 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4107 NewOp(1101, pvop, 1, PVOP);
4108 pvop->op_type = (OPCODE)type;
4109 pvop->op_ppaddr = PL_ppaddr[type];
4111 pvop->op_next = (OP*)pvop;
4112 pvop->op_flags = (U8)flags;
4113 if (PL_opargs[type] & OA_RETSCALAR)
4115 if (PL_opargs[type] & OA_TARGET)
4116 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4117 return CHECKOP(type, pvop);
4125 Perl_package(pTHX_ OP *o)
4128 SV *const sv = cSVOPo->op_sv;
4133 PERL_ARGS_ASSERT_PACKAGE;
4135 save_hptr(&PL_curstash);
4136 save_item(PL_curstname);
4138 PL_curstash = gv_stashsv(sv, GV_ADD);
4140 sv_setsv(PL_curstname, sv);
4142 PL_hints |= HINT_BLOCK_SCOPE;
4143 PL_parser->copline = NOLINE;
4144 PL_parser->expect = XSTATE;
4149 if (!PL_madskills) {
4154 pegop = newOP(OP_NULL,0);
4155 op_getmad(o,pegop,'P');
4161 Perl_package_version( pTHX_ OP *v )
4164 U32 savehints = PL_hints;
4165 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4166 PL_hints &= ~HINT_STRICT_VARS;
4167 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4168 PL_hints = savehints;
4177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4184 OP *pegop = newOP(OP_NULL,0);
4187 PERL_ARGS_ASSERT_UTILIZE;
4189 if (idop->op_type != OP_CONST)
4190 Perl_croak(aTHX_ "Module name must be constant");
4193 op_getmad(idop,pegop,'U');
4198 SV * const vesv = ((SVOP*)version)->op_sv;
4201 op_getmad(version,pegop,'V');
4202 if (!arg && !SvNIOKp(vesv)) {
4209 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4210 Perl_croak(aTHX_ "Version number must be a constant number");
4212 /* Make copy of idop so we don't free it twice */
4213 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4215 /* Fake up a method call to VERSION */
4216 meth = newSVpvs_share("VERSION");
4217 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4218 op_append_elem(OP_LIST,
4219 op_prepend_elem(OP_LIST, pack, list(version)),
4220 newSVOP(OP_METHOD_NAMED, 0, meth)));
4224 /* Fake up an import/unimport */
4225 if (arg && arg->op_type == OP_STUB) {
4227 op_getmad(arg,pegop,'S');
4228 imop = arg; /* no import on explicit () */
4230 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4231 imop = NULL; /* use 5.0; */
4233 idop->op_private |= OPpCONST_NOVER;
4239 op_getmad(arg,pegop,'A');
4241 /* Make copy of idop so we don't free it twice */
4242 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4244 /* Fake up a method call to import/unimport */
4246 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4247 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4248 op_append_elem(OP_LIST,
4249 op_prepend_elem(OP_LIST, pack, list(arg)),
4250 newSVOP(OP_METHOD_NAMED, 0, meth)));
4253 /* Fake up the BEGIN {}, which does its thing immediately. */
4255 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4258 op_append_elem(OP_LINESEQ,
4259 op_append_elem(OP_LINESEQ,
4260 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4261 newSTATEOP(0, NULL, veop)),
4262 newSTATEOP(0, NULL, imop) ));
4264 /* The "did you use incorrect case?" warning used to be here.
4265 * The problem is that on case-insensitive filesystems one
4266 * might get false positives for "use" (and "require"):
4267 * "use Strict" or "require CARP" will work. This causes
4268 * portability problems for the script: in case-strict
4269 * filesystems the script will stop working.
4271 * The "incorrect case" warning checked whether "use Foo"
4272 * imported "Foo" to your namespace, but that is wrong, too:
4273 * there is no requirement nor promise in the language that
4274 * a Foo.pm should or would contain anything in package "Foo".
4276 * There is very little Configure-wise that can be done, either:
4277 * the case-sensitivity of the build filesystem of Perl does not
4278 * help in guessing the case-sensitivity of the runtime environment.
4281 PL_hints |= HINT_BLOCK_SCOPE;
4282 PL_parser->copline = NOLINE;
4283 PL_parser->expect = XSTATE;
4284 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4287 if (!PL_madskills) {
4288 /* FIXME - don't allocate pegop if !PL_madskills */
4297 =head1 Embedding Functions
4299 =for apidoc load_module
4301 Loads the module whose name is pointed to by the string part of name.
4302 Note that the actual module name, not its filename, should be given.
4303 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4304 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4305 (or 0 for no flags). ver, if specified, provides version semantics
4306 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4307 arguments can be used to specify arguments to the module's import()
4308 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4309 terminated with a final NULL pointer. Note that this list can only
4310 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4311 Otherwise at least a single NULL pointer to designate the default
4312 import list is required.
4317 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4321 PERL_ARGS_ASSERT_LOAD_MODULE;
4323 va_start(args, ver);
4324 vload_module(flags, name, ver, &args);
4328 #ifdef PERL_IMPLICIT_CONTEXT
4330 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4334 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4335 va_start(args, ver);
4336 vload_module(flags, name, ver, &args);
4342 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4346 OP * const modname = newSVOP(OP_CONST, 0, name);
4348 PERL_ARGS_ASSERT_VLOAD_MODULE;
4350 modname->op_private |= OPpCONST_BARE;
4352 veop = newSVOP(OP_CONST, 0, ver);
4356 if (flags & PERL_LOADMOD_NOIMPORT) {
4357 imop = sawparens(newNULLLIST());
4359 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4360 imop = va_arg(*args, OP*);
4365 sv = va_arg(*args, SV*);
4367 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4368 sv = va_arg(*args, SV*);
4372 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4373 * that it has a PL_parser to play with while doing that, and also
4374 * that it doesn't mess with any existing parser, by creating a tmp
4375 * new parser with lex_start(). This won't actually be used for much,
4376 * since pp_require() will create another parser for the real work. */
4379 SAVEVPTR(PL_curcop);
4380 lex_start(NULL, NULL, 0);
4381 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4382 veop, modname, imop);
4387 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4393 PERL_ARGS_ASSERT_DOFILE;
4395 if (!force_builtin) {
4396 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4397 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4398 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4399 gv = gvp ? *gvp : NULL;
4403 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4404 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4405 op_append_elem(OP_LIST, term,
4406 scalar(newUNOP(OP_RV2CV, 0,
4407 newGVOP(OP_GV, 0, gv))))));
4410 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4416 =head1 Optree construction
4418 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4420 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4421 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4422 be set automatically, and, shifted up eight bits, the eight bits of
4423 C<op_private>, except that the bit with value 1 or 2 is automatically
4424 set as required. I<listval> and I<subscript> supply the parameters of
4425 the slice; they are consumed by this function and become part of the
4426 constructed op tree.
4432 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4434 return newBINOP(OP_LSLICE, flags,
4435 list(force_list(subscript)),
4436 list(force_list(listval)) );
4440 S_is_list_assignment(pTHX_ register const OP *o)
4448 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4449 o = cUNOPo->op_first;
4451 flags = o->op_flags;
4453 if (type == OP_COND_EXPR) {
4454 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4455 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4460 yyerror("Assignment to both a list and a scalar");
4464 if (type == OP_LIST &&
4465 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4466 o->op_private & OPpLVAL_INTRO)
4469 if (type == OP_LIST || flags & OPf_PARENS ||
4470 type == OP_RV2AV || type == OP_RV2HV ||
4471 type == OP_ASLICE || type == OP_HSLICE)
4474 if (type == OP_PADAV || type == OP_PADHV)
4477 if (type == OP_RV2SV)
4484 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4486 Constructs, checks, and returns an assignment op. I<left> and I<right>
4487 supply the parameters of the assignment; they are consumed by this
4488 function and become part of the constructed op tree.
4490 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4491 a suitable conditional optree is constructed. If I<optype> is the opcode
4492 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4493 performs the binary operation and assigns the result to the left argument.
4494 Either way, if I<optype> is non-zero then I<flags> has no effect.
4496 If I<optype> is zero, then a plain scalar or list assignment is
4497 constructed. Which type of assignment it is is automatically determined.
4498 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4499 will be set automatically, and, shifted up eight bits, the eight bits
4500 of C<op_private>, except that the bit with value 1 or 2 is automatically
4507 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4513 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4514 return newLOGOP(optype, 0,
4515 mod(scalar(left), optype),
4516 newUNOP(OP_SASSIGN, 0, scalar(right)));
4519 return newBINOP(optype, OPf_STACKED,
4520 mod(scalar(left), optype), scalar(right));
4524 if (is_list_assignment(left)) {
4525 static const char no_list_state[] = "Initialization of state variables"
4526 " in list context currently forbidden";
4528 bool maybe_common_vars = TRUE;
4531 /* Grandfathering $[ assignment here. Bletch.*/
4532 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4533 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4534 left = mod(left, OP_AASSIGN);
4537 else if (left->op_type == OP_CONST) {
4538 deprecate("assignment to $[");
4540 /* Result of assignment is always 1 (or we'd be dead already) */
4541 return newSVOP(OP_CONST, 0, newSViv(1));
4543 curop = list(force_list(left));
4544 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4545 o->op_private = (U8)(0 | (flags >> 8));
4547 if ((left->op_type == OP_LIST
4548 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4550 OP* lop = ((LISTOP*)left)->op_first;
4551 maybe_common_vars = FALSE;
4553 if (lop->op_type == OP_PADSV ||
4554 lop->op_type == OP_PADAV ||
4555 lop->op_type == OP_PADHV ||
4556 lop->op_type == OP_PADANY) {
4557 if (!(lop->op_private & OPpLVAL_INTRO))
4558 maybe_common_vars = TRUE;
4560 if (lop->op_private & OPpPAD_STATE) {
4561 if (left->op_private & OPpLVAL_INTRO) {
4562 /* Each variable in state($a, $b, $c) = ... */
4565 /* Each state variable in
4566 (state $a, my $b, our $c, $d, undef) = ... */
4568 yyerror(no_list_state);
4570 /* Each my variable in
4571 (state $a, my $b, our $c, $d, undef) = ... */
4573 } else if (lop->op_type == OP_UNDEF ||
4574 lop->op_type == OP_PUSHMARK) {
4575 /* undef may be interesting in
4576 (state $a, undef, state $c) */
4578 /* Other ops in the list. */
4579 maybe_common_vars = TRUE;
4581 lop = lop->op_sibling;
4584 else if ((left->op_private & OPpLVAL_INTRO)
4585 && ( left->op_type == OP_PADSV
4586 || left->op_type == OP_PADAV
4587 || left->op_type == OP_PADHV
4588 || left->op_type == OP_PADANY))
4590 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4591 if (left->op_private & OPpPAD_STATE) {
4592 /* All single variable list context state assignments, hence
4602 yyerror(no_list_state);
4606 /* PL_generation sorcery:
4607 * an assignment like ($a,$b) = ($c,$d) is easier than
4608 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4609 * To detect whether there are common vars, the global var
4610 * PL_generation is incremented for each assign op we compile.
4611 * Then, while compiling the assign op, we run through all the
4612 * variables on both sides of the assignment, setting a spare slot
4613 * in each of them to PL_generation. If any of them already have
4614 * that value, we know we've got commonality. We could use a
4615 * single bit marker, but then we'd have to make 2 passes, first
4616 * to clear the flag, then to test and set it. To find somewhere
4617 * to store these values, evil chicanery is done with SvUVX().
4620 if (maybe_common_vars) {
4623 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4624 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4625 if (curop->op_type == OP_GV) {
4626 GV *gv = cGVOPx_gv(curop);
4628 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4630 GvASSIGN_GENERATION_set(gv, PL_generation);
4632 else if (curop->op_type == OP_PADSV ||
4633 curop->op_type == OP_PADAV ||
4634 curop->op_type == OP_PADHV ||
4635 curop->op_type == OP_PADANY)
4637 if (PAD_COMPNAME_GEN(curop->op_targ)
4638 == (STRLEN)PL_generation)
4640 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4643 else if (curop->op_type == OP_RV2CV)
4645 else if (curop->op_type == OP_RV2SV ||
4646 curop->op_type == OP_RV2AV ||
4647 curop->op_type == OP_RV2HV ||
4648 curop->op_type == OP_RV2GV) {
4649 if (lastop->op_type != OP_GV) /* funny deref? */
4652 else if (curop->op_type == OP_PUSHRE) {
4654 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4655 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4657 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4659 GvASSIGN_GENERATION_set(gv, PL_generation);
4663 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4666 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4668 GvASSIGN_GENERATION_set(gv, PL_generation);
4678 o->op_private |= OPpASSIGN_COMMON;
4681 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4682 OP* tmpop = ((LISTOP*)right)->op_first;
4683 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4684 PMOP * const pm = (PMOP*)tmpop;
4685 if (left->op_type == OP_RV2AV &&
4686 !(left->op_private & OPpLVAL_INTRO) &&
4687 !(o->op_private & OPpASSIGN_COMMON) )
4689 tmpop = ((UNOP*)left)->op_first;
4690 if (tmpop->op_type == OP_GV
4692 && !pm->op_pmreplrootu.op_pmtargetoff
4694 && !pm->op_pmreplrootu.op_pmtargetgv
4698 pm->op_pmreplrootu.op_pmtargetoff
4699 = cPADOPx(tmpop)->op_padix;
4700 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4702 pm->op_pmreplrootu.op_pmtargetgv
4703 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4704 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4706 pm->op_pmflags |= PMf_ONCE;
4707 tmpop = cUNOPo->op_first; /* to list (nulled) */
4708 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4709 tmpop->op_sibling = NULL; /* don't free split */
4710 right->op_next = tmpop->op_next; /* fix starting loc */
4711 op_free(o); /* blow off assign */
4712 right->op_flags &= ~OPf_WANT;
4713 /* "I don't know and I don't care." */
4718 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4719 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4721 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4722 if (SvIOK(sv) && SvIVX(sv) == 0)
4723 sv_setiv(sv, PL_modcount+1);
4731 right = newOP(OP_UNDEF, 0);
4732 if (right->op_type == OP_READLINE) {
4733 right->op_flags |= OPf_STACKED;
4734 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4737 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4738 o = newBINOP(OP_SASSIGN, flags,
4739 scalar(right), mod(scalar(left), OP_SASSIGN) );
4743 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4744 deprecate("assignment to $[");
4746 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4747 o->op_private |= OPpCONST_ARYBASE;
4755 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4757 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4758 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4759 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4760 If I<label> is non-null, it supplies the name of a label to attach to
4761 the state op; this function takes ownership of the memory pointed at by
4762 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4765 If I<o> is null, the state op is returned. Otherwise the state op is
4766 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4767 is consumed by this function and becomes part of the returned op tree.
4773 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4776 const U32 seq = intro_my();
4779 NewOp(1101, cop, 1, COP);
4780 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4781 cop->op_type = OP_DBSTATE;
4782 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4785 cop->op_type = OP_NEXTSTATE;
4786 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4788 cop->op_flags = (U8)flags;
4789 CopHINTS_set(cop, PL_hints);
4791 cop->op_private |= NATIVE_HINTS;
4793 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4794 cop->op_next = (OP*)cop;
4797 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4798 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4800 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4801 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4803 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4805 PL_hints |= HINT_BLOCK_SCOPE;
4806 /* It seems that we need to defer freeing this pointer, as other parts
4807 of the grammar end up wanting to copy it after this op has been
4812 if (PL_parser && PL_parser->copline == NOLINE)
4813 CopLINE_set(cop, CopLINE(PL_curcop));
4815 CopLINE_set(cop, PL_parser->copline);
4817 PL_parser->copline = NOLINE;
4820 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4822 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4824 CopSTASH_set(cop, PL_curstash);
4826 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4827 /* this line can have a breakpoint - store the cop in IV */
4828 AV *av = CopFILEAVx(PL_curcop);
4830 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4831 if (svp && *svp != &PL_sv_undef ) {
4832 (void)SvIOK_on(*svp);
4833 SvIV_set(*svp, PTR2IV(cop));
4838 if (flags & OPf_SPECIAL)
4840 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4844 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4846 Constructs, checks, and returns a logical (flow control) op. I<type>
4847 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4848 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4849 the eight bits of C<op_private>, except that the bit with value 1 is
4850 automatically set. I<first> supplies the expression controlling the
4851 flow, and I<other> supplies the side (alternate) chain of ops; they are
4852 consumed by this function and become part of the constructed op tree.
4858 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4862 PERL_ARGS_ASSERT_NEWLOGOP;
4864 return new_logop(type, flags, &first, &other);
4868 S_search_const(pTHX_ OP *o)
4870 PERL_ARGS_ASSERT_SEARCH_CONST;
4872 switch (o->op_type) {
4876 if (o->op_flags & OPf_KIDS)
4877 return search_const(cUNOPo->op_first);
4884 if (!(o->op_flags & OPf_KIDS))
4886 kid = cLISTOPo->op_first;
4888 switch (kid->op_type) {
4892 kid = kid->op_sibling;
4895 if (kid != cLISTOPo->op_last)
4901 kid = cLISTOPo->op_last;
4903 return search_const(kid);
4911 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4919 int prepend_not = 0;
4921 PERL_ARGS_ASSERT_NEW_LOGOP;
4926 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4927 return newBINOP(type, flags, scalar(first), scalar(other));
4929 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4931 scalarboolean(first);
4932 /* optimize AND and OR ops that have NOTs as children */
4933 if (first->op_type == OP_NOT
4934 && (first->op_flags & OPf_KIDS)
4935 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4936 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4938 if (type == OP_AND || type == OP_OR) {
4944 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4946 prepend_not = 1; /* prepend a NOT op later */
4950 /* search for a constant op that could let us fold the test */
4951 if ((cstop = search_const(first))) {
4952 if (cstop->op_private & OPpCONST_STRICT)
4953 no_bareword_allowed(cstop);
4954 else if ((cstop->op_private & OPpCONST_BARE))
4955 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4956 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4957 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4958 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4960 if (other->op_type == OP_CONST)
4961 other->op_private |= OPpCONST_SHORTCIRCUIT;
4963 OP *newop = newUNOP(OP_NULL, 0, other);
4964 op_getmad(first, newop, '1');
4965 newop->op_targ = type; /* set "was" field */
4969 if (other->op_type == OP_LEAVE)
4970 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4971 else if (other->op_type == OP_MATCH
4972 || other->op_type == OP_SUBST
4973 || other->op_type == OP_TRANS)
4974 /* Mark the op as being unbindable with =~ */
4975 other->op_flags |= OPf_SPECIAL;
4979 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4980 const OP *o2 = other;
4981 if ( ! (o2->op_type == OP_LIST
4982 && (( o2 = cUNOPx(o2)->op_first))
4983 && o2->op_type == OP_PUSHMARK
4984 && (( o2 = o2->op_sibling)) )
4987 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4988 || o2->op_type == OP_PADHV)
4989 && o2->op_private & OPpLVAL_INTRO
4990 && !(o2->op_private & OPpPAD_STATE))
4992 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4993 "Deprecated use of my() in false conditional");
4997 if (first->op_type == OP_CONST)
4998 first->op_private |= OPpCONST_SHORTCIRCUIT;
5000 first = newUNOP(OP_NULL, 0, first);
5001 op_getmad(other, first, '2');
5002 first->op_targ = type; /* set "was" field */
5009 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5010 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5012 const OP * const k1 = ((UNOP*)first)->op_first;
5013 const OP * const k2 = k1->op_sibling;
5015 switch (first->op_type)
5018 if (k2 && k2->op_type == OP_READLINE
5019 && (k2->op_flags & OPf_STACKED)
5020 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5022 warnop = k2->op_type;
5027 if (k1->op_type == OP_READDIR
5028 || k1->op_type == OP_GLOB
5029 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5030 || k1->op_type == OP_EACH)
5032 warnop = ((k1->op_type == OP_NULL)
5033 ? (OPCODE)k1->op_targ : k1->op_type);
5038 const line_t oldline = CopLINE(PL_curcop);
5039 CopLINE_set(PL_curcop, PL_parser->copline);
5040 Perl_warner(aTHX_ packWARN(WARN_MISC),
5041 "Value of %s%s can be \"0\"; test with defined()",
5043 ((warnop == OP_READLINE || warnop == OP_GLOB)
5044 ? " construct" : "() operator"));
5045 CopLINE_set(PL_curcop, oldline);
5052 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5053 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5055 NewOp(1101, logop, 1, LOGOP);
5057 logop->op_type = (OPCODE)type;
5058 logop->op_ppaddr = PL_ppaddr[type];
5059 logop->op_first = first;
5060 logop->op_flags = (U8)(flags | OPf_KIDS);
5061 logop->op_other = LINKLIST(other);
5062 logop->op_private = (U8)(1 | (flags >> 8));
5064 /* establish postfix order */
5065 logop->op_next = LINKLIST(first);
5066 first->op_next = (OP*)logop;
5067 first->op_sibling = other;
5069 CHECKOP(type,logop);
5071 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5078 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5080 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5081 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5082 will be set automatically, and, shifted up eight bits, the eight bits of
5083 C<op_private>, except that the bit with value 1 is automatically set.
5084 I<first> supplies the expression selecting between the two branches,
5085 and I<trueop> and I<falseop> supply the branches; they are consumed by
5086 this function and become part of the constructed op tree.
5092 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5100 PERL_ARGS_ASSERT_NEWCONDOP;
5103 return newLOGOP(OP_AND, 0, first, trueop);
5105 return newLOGOP(OP_OR, 0, first, falseop);
5107 scalarboolean(first);
5108 if ((cstop = search_const(first))) {
5109 /* Left or right arm of the conditional? */
5110 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5111 OP *live = left ? trueop : falseop;
5112 OP *const dead = left ? falseop : trueop;
5113 if (cstop->op_private & OPpCONST_BARE &&
5114 cstop->op_private & OPpCONST_STRICT) {
5115 no_bareword_allowed(cstop);
5118 /* This is all dead code when PERL_MAD is not defined. */
5119 live = newUNOP(OP_NULL, 0, live);
5120 op_getmad(first, live, 'C');
5121 op_getmad(dead, live, left ? 'e' : 't');
5126 if (live->op_type == OP_LEAVE)
5127 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5128 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5129 || live->op_type == OP_TRANS)
5130 /* Mark the op as being unbindable with =~ */
5131 live->op_flags |= OPf_SPECIAL;
5134 NewOp(1101, logop, 1, LOGOP);
5135 logop->op_type = OP_COND_EXPR;
5136 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5137 logop->op_first = first;
5138 logop->op_flags = (U8)(flags | OPf_KIDS);
5139 logop->op_private = (U8)(1 | (flags >> 8));
5140 logop->op_other = LINKLIST(trueop);
5141 logop->op_next = LINKLIST(falseop);
5143 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5146 /* establish postfix order */
5147 start = LINKLIST(first);
5148 first->op_next = (OP*)logop;
5150 first->op_sibling = trueop;
5151 trueop->op_sibling = falseop;
5152 o = newUNOP(OP_NULL, 0, (OP*)logop);
5154 trueop->op_next = falseop->op_next = o;
5161 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5163 Constructs and returns a C<range> op, with subordinate C<flip> and
5164 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5165 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5166 for both the C<flip> and C<range> ops, except that the bit with value
5167 1 is automatically set. I<left> and I<right> supply the expressions
5168 controlling the endpoints of the range; they are consumed by this function
5169 and become part of the constructed op tree.
5175 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5184 PERL_ARGS_ASSERT_NEWRANGE;
5186 NewOp(1101, range, 1, LOGOP);
5188 range->op_type = OP_RANGE;
5189 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5190 range->op_first = left;
5191 range->op_flags = OPf_KIDS;
5192 leftstart = LINKLIST(left);
5193 range->op_other = LINKLIST(right);
5194 range->op_private = (U8)(1 | (flags >> 8));
5196 left->op_sibling = right;
5198 range->op_next = (OP*)range;
5199 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5200 flop = newUNOP(OP_FLOP, 0, flip);
5201 o = newUNOP(OP_NULL, 0, flop);
5203 range->op_next = leftstart;
5205 left->op_next = flip;
5206 right->op_next = flop;
5208 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5209 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5210 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5211 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5213 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5214 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5217 if (!flip->op_private || !flop->op_private)
5218 LINKLIST(o); /* blow off optimizer unless constant */
5224 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5226 Constructs, checks, and returns an op tree expressing a loop. This is
5227 only a loop in the control flow through the op tree; it does not have
5228 the heavyweight loop structure that allows exiting the loop by C<last>
5229 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5230 top-level op, except that some bits will be set automatically as required.
5231 I<expr> supplies the expression controlling loop iteration, and I<block>
5232 supplies the body of the loop; they are consumed by this function and
5233 become part of the constructed op tree. I<debuggable> is currently
5234 unused and should always be 1.
5240 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5245 const bool once = block && block->op_flags & OPf_SPECIAL &&
5246 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5248 PERL_UNUSED_ARG(debuggable);
5251 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5252 return block; /* do {} while 0 does once */
5253 if (expr->op_type == OP_READLINE
5254 || expr->op_type == OP_READDIR
5255 || expr->op_type == OP_GLOB
5256 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5257 expr = newUNOP(OP_DEFINED, 0,
5258 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5259 } else if (expr->op_flags & OPf_KIDS) {
5260 const OP * const k1 = ((UNOP*)expr)->op_first;
5261 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5262 switch (expr->op_type) {
5264 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5265 && (k2->op_flags & OPf_STACKED)
5266 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5267 expr = newUNOP(OP_DEFINED, 0, expr);
5271 if (k1 && (k1->op_type == OP_READDIR
5272 || k1->op_type == OP_GLOB
5273 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5274 || k1->op_type == OP_EACH))
5275 expr = newUNOP(OP_DEFINED, 0, expr);
5281 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5282 * op, in listop. This is wrong. [perl #27024] */
5284 block = newOP(OP_NULL, 0);
5285 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5286 o = new_logop(OP_AND, 0, &expr, &listop);
5289 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5291 if (once && o != listop)
5292 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5295 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5297 o->op_flags |= flags;
5299 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5304 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5306 Constructs, checks, and returns an op tree expressing a C<while> loop.
5307 This is a heavyweight loop, with structure that allows exiting the loop
5308 by C<last> and suchlike.
5310 I<loop> is an optional preconstructed C<enterloop> op to use in the
5311 loop; if it is null then a suitable op will be constructed automatically.
5312 I<expr> supplies the loop's controlling expression. I<block> supplies the
5313 main body of the loop, and I<cont> optionally supplies a C<continue> block
5314 that operates as a second half of the body. All of these optree inputs
5315 are consumed by this function and become part of the constructed op tree.
5317 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5318 op and, shifted up eight bits, the eight bits of C<op_private> for
5319 the C<leaveloop> op, except that (in both cases) some bits will be set
5320 automatically. I<debuggable> is currently unused and should always be 1.
5321 I<has_my> can be supplied as true to force the
5322 loop body to be enclosed in its own scope.
5328 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5329 OP *expr, OP *block, OP *cont, I32 has_my)
5338 PERL_UNUSED_ARG(debuggable);
5341 if (expr->op_type == OP_READLINE
5342 || expr->op_type == OP_READDIR
5343 || expr->op_type == OP_GLOB
5344 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5345 expr = newUNOP(OP_DEFINED, 0,
5346 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5347 } else if (expr->op_flags & OPf_KIDS) {
5348 const OP * const k1 = ((UNOP*)expr)->op_first;
5349 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5350 switch (expr->op_type) {
5352 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5353 && (k2->op_flags & OPf_STACKED)
5354 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5355 expr = newUNOP(OP_DEFINED, 0, expr);
5359 if (k1 && (k1->op_type == OP_READDIR
5360 || k1->op_type == OP_GLOB
5361 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5362 || k1->op_type == OP_EACH))
5363 expr = newUNOP(OP_DEFINED, 0, expr);
5370 block = newOP(OP_NULL, 0);
5371 else if (cont || has_my) {
5372 block = scope(block);
5376 next = LINKLIST(cont);
5379 OP * const unstack = newOP(OP_UNSTACK, 0);
5382 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5386 listop = op_append_list(OP_LINESEQ, block, cont);
5388 redo = LINKLIST(listop);
5392 o = new_logop(OP_AND, 0, &expr, &listop);
5393 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5394 op_free(expr); /* oops, it's a while (0) */
5396 return NULL; /* listop already freed by new_logop */
5399 ((LISTOP*)listop)->op_last->op_next =
5400 (o == listop ? redo : LINKLIST(o));
5406 NewOp(1101,loop,1,LOOP);
5407 loop->op_type = OP_ENTERLOOP;
5408 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5409 loop->op_private = 0;
5410 loop->op_next = (OP*)loop;
5413 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5415 loop->op_redoop = redo;
5416 loop->op_lastop = o;
5417 o->op_private |= loopflags;
5420 loop->op_nextop = next;
5422 loop->op_nextop = o;
5424 o->op_flags |= flags;
5425 o->op_private |= (flags >> 8);
5430 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5432 Constructs, checks, and returns an op tree expressing a C<foreach>
5433 loop (iteration through a list of values). This is a heavyweight loop,
5434 with structure that allows exiting the loop by C<last> and suchlike.
5436 I<sv> optionally supplies the variable that will be aliased to each
5437 item in turn; if null, it defaults to C<$_> (either lexical or global).
5438 I<expr> supplies the list of values to iterate over. I<block> supplies
5439 the main body of the loop, and I<cont> optionally supplies a C<continue>
5440 block that operates as a second half of the body. All of these optree
5441 inputs are consumed by this function and become part of the constructed
5444 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5445 op and, shifted up eight bits, the eight bits of C<op_private> for
5446 the C<leaveloop> op, except that (in both cases) some bits will be set
5453 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5458 PADOFFSET padoff = 0;
5463 PERL_ARGS_ASSERT_NEWFOROP;
5466 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5467 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5468 sv->op_type = OP_RV2GV;
5469 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5471 /* The op_type check is needed to prevent a possible segfault
5472 * if the loop variable is undeclared and 'strict vars' is in
5473 * effect. This is illegal but is nonetheless parsed, so we
5474 * may reach this point with an OP_CONST where we're expecting
5477 if (cUNOPx(sv)->op_first->op_type == OP_GV
5478 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5479 iterpflags |= OPpITER_DEF;
5481 else if (sv->op_type == OP_PADSV) { /* private variable */
5482 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5483 padoff = sv->op_targ;
5493 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5495 SV *const namesv = PAD_COMPNAME_SV(padoff);
5497 const char *const name = SvPV_const(namesv, len);
5499 if (len == 2 && name[0] == '$' && name[1] == '_')
5500 iterpflags |= OPpITER_DEF;
5504 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5505 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5506 sv = newGVOP(OP_GV, 0, PL_defgv);
5511 iterpflags |= OPpITER_DEF;
5513 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5514 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5515 iterflags |= OPf_STACKED;
5517 else if (expr->op_type == OP_NULL &&
5518 (expr->op_flags & OPf_KIDS) &&
5519 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5521 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5522 * set the STACKED flag to indicate that these values are to be
5523 * treated as min/max values by 'pp_iterinit'.
5525 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5526 LOGOP* const range = (LOGOP*) flip->op_first;
5527 OP* const left = range->op_first;
5528 OP* const right = left->op_sibling;
5531 range->op_flags &= ~OPf_KIDS;
5532 range->op_first = NULL;
5534 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5535 listop->op_first->op_next = range->op_next;
5536 left->op_next = range->op_other;
5537 right->op_next = (OP*)listop;
5538 listop->op_next = listop->op_first;
5541 op_getmad(expr,(OP*)listop,'O');
5545 expr = (OP*)(listop);
5547 iterflags |= OPf_STACKED;
5550 expr = mod(force_list(expr), OP_GREPSTART);
5553 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5554 op_append_elem(OP_LIST, expr, scalar(sv))));
5555 assert(!loop->op_next);
5556 /* for my $x () sets OPpLVAL_INTRO;
5557 * for our $x () sets OPpOUR_INTRO */
5558 loop->op_private = (U8)iterpflags;
5559 #ifdef PL_OP_SLAB_ALLOC
5562 NewOp(1234,tmp,1,LOOP);
5563 Copy(loop,tmp,1,LISTOP);
5564 S_op_destroy(aTHX_ (OP*)loop);
5568 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5570 loop->op_targ = padoff;
5571 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
5573 op_getmad(madsv, (OP*)loop, 'v');
5578 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5580 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5581 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5582 determining the target of the op; it is consumed by this function and
5583 become part of the constructed op tree.
5589 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5594 PERL_ARGS_ASSERT_NEWLOOPEX;
5596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5598 if (type != OP_GOTO || label->op_type == OP_CONST) {
5599 /* "last()" means "last" */
5600 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5601 o = newOP(type, OPf_SPECIAL);
5603 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5604 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5608 op_getmad(label,o,'L');
5614 /* Check whether it's going to be a goto &function */
5615 if (label->op_type == OP_ENTERSUB
5616 && !(label->op_flags & OPf_STACKED))
5617 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5618 o = newUNOP(type, OPf_STACKED, label);
5620 PL_hints |= HINT_BLOCK_SCOPE;
5624 /* if the condition is a literal array or hash
5625 (or @{ ... } etc), make a reference to it.
5628 S_ref_array_or_hash(pTHX_ OP *cond)
5631 && (cond->op_type == OP_RV2AV
5632 || cond->op_type == OP_PADAV
5633 || cond->op_type == OP_RV2HV
5634 || cond->op_type == OP_PADHV))
5636 return newUNOP(OP_REFGEN,
5637 0, mod(cond, OP_REFGEN));
5640 && (cond->op_type == OP_ASLICE
5641 || cond->op_type == OP_HSLICE)) {
5643 /* anonlist now needs a list from this op, was previously used in
5645 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5646 cond->op_flags |= OPf_WANT_LIST;
5648 return newANONLIST(mod(cond, OP_ANONLIST));
5655 /* These construct the optree fragments representing given()
5658 entergiven and enterwhen are LOGOPs; the op_other pointer
5659 points up to the associated leave op. We need this so we
5660 can put it in the context and make break/continue work.
5661 (Also, of course, pp_enterwhen will jump straight to
5662 op_other if the match fails.)
5666 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5667 I32 enter_opcode, I32 leave_opcode,
5668 PADOFFSET entertarg)
5674 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5676 NewOp(1101, enterop, 1, LOGOP);
5677 enterop->op_type = (Optype)enter_opcode;
5678 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5679 enterop->op_flags = (U8) OPf_KIDS;
5680 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5681 enterop->op_private = 0;
5683 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5686 enterop->op_first = scalar(cond);
5687 cond->op_sibling = block;
5689 o->op_next = LINKLIST(cond);
5690 cond->op_next = (OP *) enterop;
5693 /* This is a default {} block */
5694 enterop->op_first = block;
5695 enterop->op_flags |= OPf_SPECIAL;
5697 o->op_next = (OP *) enterop;
5700 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5701 entergiven and enterwhen both
5704 enterop->op_next = LINKLIST(block);
5705 block->op_next = enterop->op_other = o;
5710 /* Does this look like a boolean operation? For these purposes
5711 a boolean operation is:
5712 - a subroutine call [*]
5713 - a logical connective
5714 - a comparison operator
5715 - a filetest operator, with the exception of -s -M -A -C
5716 - defined(), exists() or eof()
5717 - /$re/ or $foo =~ /$re/
5719 [*] possibly surprising
5722 S_looks_like_bool(pTHX_ const OP *o)
5726 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5728 switch(o->op_type) {
5731 return looks_like_bool(cLOGOPo->op_first);
5735 looks_like_bool(cLOGOPo->op_first)
5736 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5741 o->op_flags & OPf_KIDS
5742 && looks_like_bool(cUNOPo->op_first));
5746 case OP_NOT: case OP_XOR:
5748 case OP_EQ: case OP_NE: case OP_LT:
5749 case OP_GT: case OP_LE: case OP_GE:
5751 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5752 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5754 case OP_SEQ: case OP_SNE: case OP_SLT:
5755 case OP_SGT: case OP_SLE: case OP_SGE:
5759 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5760 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5761 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5762 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5763 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5764 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5765 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5766 case OP_FTTEXT: case OP_FTBINARY:
5768 case OP_DEFINED: case OP_EXISTS:
5769 case OP_MATCH: case OP_EOF:
5776 /* Detect comparisons that have been optimized away */
5777 if (cSVOPo->op_sv == &PL_sv_yes
5778 || cSVOPo->op_sv == &PL_sv_no)
5791 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5793 Constructs, checks, and returns an op tree expressing a C<given> block.
5794 I<cond> supplies the expression that will be locally assigned to a lexical
5795 variable, and I<block> supplies the body of the C<given> construct; they
5796 are consumed by this function and become part of the constructed op tree.
5797 I<defsv_off> is the pad offset of the scalar lexical variable that will
5804 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5807 PERL_ARGS_ASSERT_NEWGIVENOP;
5808 return newGIVWHENOP(
5809 ref_array_or_hash(cond),
5811 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5816 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5818 Constructs, checks, and returns an op tree expressing a C<when> block.
5819 I<cond> supplies the test expression, and I<block> supplies the block
5820 that will be executed if the test evaluates to true; they are consumed
5821 by this function and become part of the constructed op tree. I<cond>
5822 will be interpreted DWIMically, often as a comparison against C<$_>,
5823 and may be null to generate a C<default> block.
5829 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5831 const bool cond_llb = (!cond || looks_like_bool(cond));
5834 PERL_ARGS_ASSERT_NEWWHENOP;
5839 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5841 scalar(ref_array_or_hash(cond)));
5844 return newGIVWHENOP(
5846 op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5847 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5851 =head1 Embedding Functions
5853 =for apidoc cv_undef
5855 Clear out all the active components of a CV. This can happen either
5856 by an explicit C<undef &foo>, or by the reference count going to zero.
5857 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5858 children can still follow the full lexical scope chain.
5864 Perl_cv_undef(pTHX_ CV *cv)
5868 PERL_ARGS_ASSERT_CV_UNDEF;
5870 DEBUG_X(PerlIO_printf(Perl_debug_log,
5871 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5872 PTR2UV(cv), PTR2UV(PL_comppad))
5876 if (CvFILE(cv) && !CvISXSUB(cv)) {
5877 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5878 Safefree(CvFILE(cv));
5883 if (!CvISXSUB(cv) && CvROOT(cv)) {
5884 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5885 Perl_croak(aTHX_ "Can't undef active subroutine");
5888 PAD_SAVE_SETNULLPAD();
5890 op_free(CvROOT(cv));
5895 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5900 /* remove CvOUTSIDE unless this is an undef rather than a free */
5901 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5902 if (!CvWEAKOUTSIDE(cv))
5903 SvREFCNT_dec(CvOUTSIDE(cv));
5904 CvOUTSIDE(cv) = NULL;
5907 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5910 if (CvISXSUB(cv) && CvXSUB(cv)) {
5913 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5914 * ref status of CvOUTSIDE and CvGV */
5915 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5919 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5922 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5924 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5925 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5926 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5927 || (p && (len != SvCUR(cv) /* Not the same length. */
5928 || memNE(p, SvPVX_const(cv), len))))
5929 && ckWARN_d(WARN_PROTOTYPE)) {
5930 SV* const msg = sv_newmortal();
5934 gv_efullname3(name = sv_newmortal(), gv, NULL);
5935 sv_setpvs(msg, "Prototype mismatch:");
5937 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5939 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5941 sv_catpvs(msg, ": none");
5942 sv_catpvs(msg, " vs ");
5944 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5946 sv_catpvs(msg, "none");
5947 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5951 static void const_sv_xsub(pTHX_ CV* cv);
5955 =head1 Optree Manipulation Functions
5957 =for apidoc cv_const_sv
5959 If C<cv> is a constant sub eligible for inlining. returns the constant
5960 value returned by the sub. Otherwise, returns NULL.
5962 Constant subs can be created with C<newCONSTSUB> or as described in
5963 L<perlsub/"Constant Functions">.
5968 Perl_cv_const_sv(pTHX_ const CV *const cv)
5970 PERL_UNUSED_CONTEXT;
5973 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5975 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5978 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5979 * Can be called in 3 ways:
5982 * look for a single OP_CONST with attached value: return the value
5984 * cv && CvCLONE(cv) && !CvCONST(cv)
5986 * examine the clone prototype, and if contains only a single
5987 * OP_CONST referencing a pad const, or a single PADSV referencing
5988 * an outer lexical, return a non-zero value to indicate the CV is
5989 * a candidate for "constizing" at clone time
5993 * We have just cloned an anon prototype that was marked as a const
5994 * candidiate. Try to grab the current value, and in the case of
5995 * PADSV, ignore it if it has multiple references. Return the value.
5999 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6010 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6011 o = cLISTOPo->op_first->op_sibling;
6013 for (; o; o = o->op_next) {
6014 const OPCODE type = o->op_type;
6016 if (sv && o->op_next == o)
6018 if (o->op_next != o) {
6019 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6021 if (type == OP_DBSTATE)
6024 if (type == OP_LEAVESUB || type == OP_RETURN)
6028 if (type == OP_CONST && cSVOPo->op_sv)
6030 else if (cv && type == OP_CONST) {
6031 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6035 else if (cv && type == OP_PADSV) {
6036 if (CvCONST(cv)) { /* newly cloned anon */
6037 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6038 /* the candidate should have 1 ref from this pad and 1 ref
6039 * from the parent */
6040 if (!sv || SvREFCNT(sv) != 2)
6047 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6048 sv = &PL_sv_undef; /* an arbitrary non-null value */
6063 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6066 /* This would be the return value, but the return cannot be reached. */
6067 OP* pegop = newOP(OP_NULL, 0);
6070 PERL_UNUSED_ARG(floor);
6080 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6082 NORETURN_FUNCTION_END;
6087 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6089 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6093 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6098 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6099 register CV *cv = NULL;
6101 /* If the subroutine has no body, no attributes, and no builtin attributes
6102 then it's just a sub declaration, and we may be able to get away with
6103 storing with a placeholder scalar in the symbol table, rather than a
6104 full GV and CV. If anything is present then it will take a full CV to
6106 const I32 gv_fetch_flags
6107 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6109 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6110 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6114 assert(proto->op_type == OP_CONST);
6115 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6121 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6123 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6124 SV * const sv = sv_newmortal();
6125 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6126 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6127 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6128 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6130 } else if (PL_curstash) {
6131 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6134 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6138 if (!PL_madskills) {
6147 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6148 maximum a prototype before. */
6149 if (SvTYPE(gv) > SVt_NULL) {
6150 if (!SvPOK((const SV *)gv)
6151 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6153 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6155 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6158 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6160 sv_setiv(MUTABLE_SV(gv), -1);
6162 SvREFCNT_dec(PL_compcv);
6163 cv = PL_compcv = NULL;
6167 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6169 if (!block || !ps || *ps || attrs
6170 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6172 || block->op_type == OP_NULL
6177 const_sv = op_const_sv(block, NULL);
6180 const bool exists = CvROOT(cv) || CvXSUB(cv);
6182 /* if the subroutine doesn't exist and wasn't pre-declared
6183 * with a prototype, assume it will be AUTOLOADed,
6184 * skipping the prototype check
6186 if (exists || SvPOK(cv))
6187 cv_ckproto_len(cv, gv, ps, ps_len);
6188 /* already defined (or promised)? */
6189 if (exists || GvASSUMECV(gv)) {
6192 || block->op_type == OP_NULL
6195 if (CvFLAGS(PL_compcv)) {
6196 /* might have had built-in attrs applied */
6197 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6198 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6199 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6201 /* just a "sub foo;" when &foo is already defined */
6202 SAVEFREESV(PL_compcv);
6207 && block->op_type != OP_NULL
6210 if (ckWARN(WARN_REDEFINE)
6212 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6214 const line_t oldline = CopLINE(PL_curcop);
6215 if (PL_parser && PL_parser->copline != NOLINE)
6216 CopLINE_set(PL_curcop, PL_parser->copline);
6217 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6218 CvCONST(cv) ? "Constant subroutine %s redefined"
6219 : "Subroutine %s redefined", name);
6220 CopLINE_set(PL_curcop, oldline);
6223 if (!PL_minus_c) /* keep old one around for madskills */
6226 /* (PL_madskills unset in used file.) */
6234 SvREFCNT_inc_simple_void_NN(const_sv);
6236 assert(!CvROOT(cv) && !CvCONST(cv));
6237 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6238 CvXSUBANY(cv).any_ptr = const_sv;
6239 CvXSUB(cv) = const_sv_xsub;
6245 cv = newCONSTSUB(NULL, name, const_sv);
6247 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6248 (CvGV(cv) && GvSTASH(CvGV(cv)))
6257 SvREFCNT_dec(PL_compcv);
6261 if (cv) { /* must reuse cv if autoloaded */
6262 /* transfer PL_compcv to cv */
6265 && block->op_type != OP_NULL
6268 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6270 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6271 if (!CvWEAKOUTSIDE(cv))
6272 SvREFCNT_dec(CvOUTSIDE(cv));
6273 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6274 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6275 CvOUTSIDE(PL_compcv) = 0;
6276 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6277 CvPADLIST(PL_compcv) = 0;
6278 /* inner references to PL_compcv must be fixed up ... */
6279 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6280 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6281 ++PL_sub_generation;
6284 /* Might have had built-in attributes applied -- propagate them. */
6285 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6287 /* ... before we throw it away */
6288 SvREFCNT_dec(PL_compcv);
6296 if (strEQ(name, "import")) {
6297 PL_formfeed = MUTABLE_SV(cv);
6298 /* diag_listed_as: SKIPME */
6299 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6303 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6308 CvFILE_set_from_cop(cv, PL_curcop);
6309 CvSTASH_set(cv, PL_curstash);
6312 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6313 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6314 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6318 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6320 if (PL_parser && PL_parser->error_count) {
6324 const char *s = strrchr(name, ':');
6326 if (strEQ(s, "BEGIN")) {
6327 const char not_safe[] =
6328 "BEGIN not safe after errors--compilation aborted";
6329 if (PL_in_eval & EVAL_KEEPERR)
6330 Perl_croak(aTHX_ not_safe);
6332 /* force display of errors found but not reported */
6333 sv_catpv(ERRSV, not_safe);
6334 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6343 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6344 the debugger could be able to set a breakpoint in, so signal to
6345 pp_entereval that it should not throw away any saved lines at scope
6348 PL_breakable_sub_gen++;
6350 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6351 mod(scalarseq(block), OP_LEAVESUBLV));
6352 block->op_attached = 1;
6355 /* This makes sub {}; work as expected. */
6356 if (block->op_type == OP_STUB) {
6357 OP* const newblock = newSTATEOP(0, NULL, 0);
6359 op_getmad(block,newblock,'B');
6366 block->op_attached = 1;
6367 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6369 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6370 OpREFCNT_set(CvROOT(cv), 1);
6371 CvSTART(cv) = LINKLIST(CvROOT(cv));
6372 CvROOT(cv)->op_next = 0;
6373 CALL_PEEP(CvSTART(cv));
6375 /* now that optimizer has done its work, adjust pad values */
6377 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6380 assert(!CvCONST(cv));
6381 if (ps && !*ps && op_const_sv(block, cv))
6386 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6387 SV * const tmpstr = sv_newmortal();
6388 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6389 GV_ADDMULTI, SVt_PVHV);
6391 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6394 (long)CopLINE(PL_curcop));
6395 gv_efullname3(tmpstr, gv, NULL);
6396 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6397 SvCUR(tmpstr), sv, 0);
6398 hv = GvHVn(db_postponed);
6399 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6400 CV * const pcv = GvCV(db_postponed);
6406 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6411 if (name && ! (PL_parser && PL_parser->error_count))
6412 process_special_blocks(name, gv, cv);
6417 PL_parser->copline = NOLINE;
6423 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6426 const char *const colon = strrchr(fullname,':');
6427 const char *const name = colon ? colon + 1 : fullname;
6429 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6432 if (strEQ(name, "BEGIN")) {
6433 const I32 oldscope = PL_scopestack_ix;
6435 SAVECOPFILE(&PL_compiling);
6436 SAVECOPLINE(&PL_compiling);
6438 DEBUG_x( dump_sub(gv) );
6439 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6440 GvCV(gv) = 0; /* cv has been hijacked */
6441 call_list(oldscope, PL_beginav);
6443 PL_curcop = &PL_compiling;
6444 CopHINTS_set(&PL_compiling, PL_hints);
6451 if strEQ(name, "END") {
6452 DEBUG_x( dump_sub(gv) );
6453 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6456 } else if (*name == 'U') {
6457 if (strEQ(name, "UNITCHECK")) {
6458 /* It's never too late to run a unitcheck block */
6459 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6463 } else if (*name == 'C') {
6464 if (strEQ(name, "CHECK")) {
6466 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6467 "Too late to run CHECK block");
6468 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6472 } else if (*name == 'I') {
6473 if (strEQ(name, "INIT")) {
6475 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6476 "Too late to run INIT block");
6477 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6483 DEBUG_x( dump_sub(gv) );
6484 GvCV(gv) = 0; /* cv has been hijacked */
6489 =for apidoc newCONSTSUB
6491 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6492 eligible for inlining at compile-time.
6494 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6495 which won't be called if used as a destructor, but will suppress the overhead
6496 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6503 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6508 const char *const file = CopFILE(PL_curcop);
6510 SV *const temp_sv = CopFILESV(PL_curcop);
6511 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6516 if (IN_PERL_RUNTIME) {
6517 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6518 * an op shared between threads. Use a non-shared COP for our
6520 SAVEVPTR(PL_curcop);
6521 PL_curcop = &PL_compiling;
6523 SAVECOPLINE(PL_curcop);
6524 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6527 PL_hints &= ~HINT_BLOCK_SCOPE;
6530 SAVESPTR(PL_curstash);
6531 SAVECOPSTASH(PL_curcop);
6532 PL_curstash = stash;
6533 CopSTASH_set(PL_curcop,stash);
6536 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6537 and so doesn't get free()d. (It's expected to be from the C pre-
6538 processor __FILE__ directive). But we need a dynamically allocated one,
6539 and we need it to get freed. */
6540 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6541 XS_DYNAMIC_FILENAME);
6542 CvXSUBANY(cv).any_ptr = sv;
6547 CopSTASH_free(PL_curcop);
6555 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6556 const char *const filename, const char *const proto,
6559 CV *cv = newXS(name, subaddr, filename);
6561 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6563 if (flags & XS_DYNAMIC_FILENAME) {
6564 /* We need to "make arrangements" (ie cheat) to ensure that the
6565 filename lasts as long as the PVCV we just created, but also doesn't
6567 STRLEN filename_len = strlen(filename);
6568 STRLEN proto_and_file_len = filename_len;
6569 char *proto_and_file;
6573 proto_len = strlen(proto);
6574 proto_and_file_len += proto_len;
6576 Newx(proto_and_file, proto_and_file_len + 1, char);
6577 Copy(proto, proto_and_file, proto_len, char);
6578 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6581 proto_and_file = savepvn(filename, filename_len);
6584 /* This gets free()d. :-) */
6585 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6586 SV_HAS_TRAILING_NUL);
6588 /* This gives us the correct prototype, rather than one with the
6589 file name appended. */
6590 SvCUR_set(cv, proto_len);
6594 CvFILE(cv) = proto_and_file + proto_len;
6596 sv_setpv(MUTABLE_SV(cv), proto);
6602 =for apidoc U||newXS
6604 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6605 static storage, as it is used directly as CvFILE(), without a copy being made.
6611 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6614 GV * const gv = gv_fetchpv(name ? name :
6615 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6616 GV_ADDMULTI, SVt_PVCV);
6619 PERL_ARGS_ASSERT_NEWXS;
6622 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6624 if ((cv = (name ? GvCV(gv) : NULL))) {
6626 /* just a cached method */
6630 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6631 /* already defined (or promised) */
6632 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6633 if (ckWARN(WARN_REDEFINE)) {
6634 GV * const gvcv = CvGV(cv);
6636 HV * const stash = GvSTASH(gvcv);
6638 const char *redefined_name = HvNAME_get(stash);
6639 if ( strEQ(redefined_name,"autouse") ) {
6640 const line_t oldline = CopLINE(PL_curcop);
6641 if (PL_parser && PL_parser->copline != NOLINE)
6642 CopLINE_set(PL_curcop, PL_parser->copline);
6643 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6644 CvCONST(cv) ? "Constant subroutine %s redefined"
6645 : "Subroutine %s redefined"
6647 CopLINE_set(PL_curcop, oldline);
6657 if (cv) /* must reuse cv if autoloaded */
6660 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6664 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6670 (void)gv_fetchfile(filename);
6671 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6672 an external constant string */
6674 CvXSUB(cv) = subaddr;
6677 process_special_blocks(name, gv, cv);
6687 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6692 OP* pegop = newOP(OP_NULL, 0);
6696 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6697 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6700 if ((cv = GvFORM(gv))) {
6701 if (ckWARN(WARN_REDEFINE)) {
6702 const line_t oldline = CopLINE(PL_curcop);
6703 if (PL_parser && PL_parser->copline != NOLINE)
6704 CopLINE_set(PL_curcop, PL_parser->copline);
6706 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6707 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6709 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6710 "Format STDOUT redefined");
6712 CopLINE_set(PL_curcop, oldline);
6719 CvFILE_set_from_cop(cv, PL_curcop);
6722 pad_tidy(padtidy_FORMAT);
6723 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6724 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6725 OpREFCNT_set(CvROOT(cv), 1);
6726 CvSTART(cv) = LINKLIST(CvROOT(cv));
6727 CvROOT(cv)->op_next = 0;
6728 CALL_PEEP(CvSTART(cv));
6730 op_getmad(o,pegop,'n');
6731 op_getmad_weak(block, pegop, 'b');
6736 PL_parser->copline = NOLINE;
6744 Perl_newANONLIST(pTHX_ OP *o)
6746 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6750 Perl_newANONHASH(pTHX_ OP *o)
6752 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6756 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6758 return newANONATTRSUB(floor, proto, NULL, block);
6762 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6764 return newUNOP(OP_REFGEN, 0,
6765 newSVOP(OP_ANONCODE, 0,
6766 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6770 Perl_oopsAV(pTHX_ OP *o)
6774 PERL_ARGS_ASSERT_OOPSAV;
6776 switch (o->op_type) {
6778 o->op_type = OP_PADAV;
6779 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6780 return ref(o, OP_RV2AV);
6783 o->op_type = OP_RV2AV;
6784 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6789 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6796 Perl_oopsHV(pTHX_ OP *o)
6800 PERL_ARGS_ASSERT_OOPSHV;
6802 switch (o->op_type) {
6805 o->op_type = OP_PADHV;
6806 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6807 return ref(o, OP_RV2HV);
6811 o->op_type = OP_RV2HV;
6812 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6817 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6824 Perl_newAVREF(pTHX_ OP *o)
6828 PERL_ARGS_ASSERT_NEWAVREF;
6830 if (o->op_type == OP_PADANY) {
6831 o->op_type = OP_PADAV;
6832 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6835 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6836 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6837 "Using an array as a reference is deprecated");
6839 return newUNOP(OP_RV2AV, 0, scalar(o));
6843 Perl_newGVREF(pTHX_ I32 type, OP *o)
6845 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6846 return newUNOP(OP_NULL, 0, o);
6847 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6851 Perl_newHVREF(pTHX_ OP *o)
6855 PERL_ARGS_ASSERT_NEWHVREF;
6857 if (o->op_type == OP_PADANY) {
6858 o->op_type = OP_PADHV;
6859 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6862 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6863 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6864 "Using a hash as a reference is deprecated");
6866 return newUNOP(OP_RV2HV, 0, scalar(o));
6870 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6872 return newUNOP(OP_RV2CV, flags, scalar(o));
6876 Perl_newSVREF(pTHX_ OP *o)
6880 PERL_ARGS_ASSERT_NEWSVREF;
6882 if (o->op_type == OP_PADANY) {
6883 o->op_type = OP_PADSV;
6884 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6887 return newUNOP(OP_RV2SV, 0, scalar(o));
6890 /* Check routines. See the comments at the top of this file for details
6891 * on when these are called */
6894 Perl_ck_anoncode(pTHX_ OP *o)
6896 PERL_ARGS_ASSERT_CK_ANONCODE;
6898 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6900 cSVOPo->op_sv = NULL;
6905 Perl_ck_bitop(pTHX_ OP *o)
6909 PERL_ARGS_ASSERT_CK_BITOP;
6911 #define OP_IS_NUMCOMPARE(op) \
6912 ((op) == OP_LT || (op) == OP_I_LT || \
6913 (op) == OP_GT || (op) == OP_I_GT || \
6914 (op) == OP_LE || (op) == OP_I_LE || \
6915 (op) == OP_GE || (op) == OP_I_GE || \
6916 (op) == OP_EQ || (op) == OP_I_EQ || \
6917 (op) == OP_NE || (op) == OP_I_NE || \
6918 (op) == OP_NCMP || (op) == OP_I_NCMP)
6919 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6920 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6921 && (o->op_type == OP_BIT_OR
6922 || o->op_type == OP_BIT_AND
6923 || o->op_type == OP_BIT_XOR))
6925 const OP * const left = cBINOPo->op_first;
6926 const OP * const right = left->op_sibling;
6927 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6928 (left->op_flags & OPf_PARENS) == 0) ||
6929 (OP_IS_NUMCOMPARE(right->op_type) &&
6930 (right->op_flags & OPf_PARENS) == 0))
6931 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6932 "Possible precedence problem on bitwise %c operator",
6933 o->op_type == OP_BIT_OR ? '|'
6934 : o->op_type == OP_BIT_AND ? '&' : '^'
6941 Perl_ck_concat(pTHX_ OP *o)
6943 const OP * const kid = cUNOPo->op_first;
6945 PERL_ARGS_ASSERT_CK_CONCAT;
6946 PERL_UNUSED_CONTEXT;
6948 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6949 !(kUNOP->op_first->op_flags & OPf_MOD))
6950 o->op_flags |= OPf_STACKED;
6955 Perl_ck_spair(pTHX_ OP *o)
6959 PERL_ARGS_ASSERT_CK_SPAIR;
6961 if (o->op_flags & OPf_KIDS) {
6964 const OPCODE type = o->op_type;
6965 o = modkids(ck_fun(o), type);
6966 kid = cUNOPo->op_first;
6967 newop = kUNOP->op_first->op_sibling;
6969 const OPCODE type = newop->op_type;
6970 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6971 type == OP_PADAV || type == OP_PADHV ||
6972 type == OP_RV2AV || type == OP_RV2HV)
6976 op_getmad(kUNOP->op_first,newop,'K');
6978 op_free(kUNOP->op_first);
6980 kUNOP->op_first = newop;
6982 o->op_ppaddr = PL_ppaddr[++o->op_type];
6987 Perl_ck_delete(pTHX_ OP *o)
6989 PERL_ARGS_ASSERT_CK_DELETE;
6993 if (o->op_flags & OPf_KIDS) {
6994 OP * const kid = cUNOPo->op_first;
6995 switch (kid->op_type) {
6997 o->op_flags |= OPf_SPECIAL;
7000 o->op_private |= OPpSLICE;
7003 o->op_flags |= OPf_SPECIAL;
7008 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7011 if (kid->op_private & OPpLVAL_INTRO)
7012 o->op_private |= OPpLVAL_INTRO;
7019 Perl_ck_die(pTHX_ OP *o)
7021 PERL_ARGS_ASSERT_CK_DIE;
7024 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7030 Perl_ck_eof(pTHX_ OP *o)
7034 PERL_ARGS_ASSERT_CK_EOF;
7036 if (o->op_flags & OPf_KIDS) {
7037 if (cLISTOPo->op_first->op_type == OP_STUB) {
7039 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7041 op_getmad(o,newop,'O');
7053 Perl_ck_eval(pTHX_ OP *o)
7057 PERL_ARGS_ASSERT_CK_EVAL;
7059 PL_hints |= HINT_BLOCK_SCOPE;
7060 if (o->op_flags & OPf_KIDS) {
7061 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7064 o->op_flags &= ~OPf_KIDS;
7067 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7073 cUNOPo->op_first = 0;
7078 NewOp(1101, enter, 1, LOGOP);
7079 enter->op_type = OP_ENTERTRY;
7080 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7081 enter->op_private = 0;
7083 /* establish postfix order */
7084 enter->op_next = (OP*)enter;
7086 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7087 o->op_type = OP_LEAVETRY;
7088 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7089 enter->op_other = o;
7090 op_getmad(oldo,o,'O');
7104 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7105 op_getmad(oldo,o,'O');
7107 o->op_targ = (PADOFFSET)PL_hints;
7108 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7109 /* Store a copy of %^H that pp_entereval can pick up. */
7110 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7111 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7112 cUNOPo->op_first->op_sibling = hhop;
7113 o->op_private |= OPpEVAL_HAS_HH;
7119 Perl_ck_exit(pTHX_ OP *o)
7121 PERL_ARGS_ASSERT_CK_EXIT;
7124 HV * const table = GvHV(PL_hintgv);
7126 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7127 if (svp && *svp && SvTRUE(*svp))
7128 o->op_private |= OPpEXIT_VMSISH;
7130 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7136 Perl_ck_exec(pTHX_ OP *o)
7138 PERL_ARGS_ASSERT_CK_EXEC;
7140 if (o->op_flags & OPf_STACKED) {
7143 kid = cUNOPo->op_first->op_sibling;
7144 if (kid->op_type == OP_RV2GV)
7153 Perl_ck_exists(pTHX_ OP *o)
7157 PERL_ARGS_ASSERT_CK_EXISTS;
7160 if (o->op_flags & OPf_KIDS) {
7161 OP * const kid = cUNOPo->op_first;
7162 if (kid->op_type == OP_ENTERSUB) {
7163 (void) ref(kid, o->op_type);
7164 if (kid->op_type != OP_RV2CV
7165 && !(PL_parser && PL_parser->error_count))
7166 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7168 o->op_private |= OPpEXISTS_SUB;
7170 else if (kid->op_type == OP_AELEM)
7171 o->op_flags |= OPf_SPECIAL;
7172 else if (kid->op_type != OP_HELEM)
7173 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7181 Perl_ck_rvconst(pTHX_ register OP *o)
7184 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7186 PERL_ARGS_ASSERT_CK_RVCONST;
7188 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7189 if (o->op_type == OP_RV2CV)
7190 o->op_private &= ~1;
7192 if (kid->op_type == OP_CONST) {
7195 SV * const kidsv = kid->op_sv;
7197 /* Is it a constant from cv_const_sv()? */
7198 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7199 SV * const rsv = SvRV(kidsv);
7200 const svtype type = SvTYPE(rsv);
7201 const char *badtype = NULL;
7203 switch (o->op_type) {
7205 if (type > SVt_PVMG)
7206 badtype = "a SCALAR";
7209 if (type != SVt_PVAV)
7210 badtype = "an ARRAY";
7213 if (type != SVt_PVHV)
7217 if (type != SVt_PVCV)
7222 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7225 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7226 const char *badthing;
7227 switch (o->op_type) {
7229 badthing = "a SCALAR";
7232 badthing = "an ARRAY";
7235 badthing = "a HASH";
7243 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7244 SVfARG(kidsv), badthing);
7247 * This is a little tricky. We only want to add the symbol if we
7248 * didn't add it in the lexer. Otherwise we get duplicate strict
7249 * warnings. But if we didn't add it in the lexer, we must at
7250 * least pretend like we wanted to add it even if it existed before,
7251 * or we get possible typo warnings. OPpCONST_ENTERED says
7252 * whether the lexer already added THIS instance of this symbol.
7254 iscv = (o->op_type == OP_RV2CV) * 2;
7256 gv = gv_fetchsv(kidsv,
7257 iscv | !(kid->op_private & OPpCONST_ENTERED),
7260 : o->op_type == OP_RV2SV
7262 : o->op_type == OP_RV2AV
7264 : o->op_type == OP_RV2HV
7267 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7269 kid->op_type = OP_GV;
7270 SvREFCNT_dec(kid->op_sv);
7272 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7273 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7274 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7276 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7278 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7280 kid->op_private = 0;
7281 kid->op_ppaddr = PL_ppaddr[OP_GV];
7282 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7290 Perl_ck_ftst(pTHX_ OP *o)
7293 const I32 type = o->op_type;
7295 PERL_ARGS_ASSERT_CK_FTST;
7297 if (o->op_flags & OPf_REF) {
7300 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7301 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7302 const OPCODE kidtype = kid->op_type;
7304 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7305 OP * const newop = newGVOP(type, OPf_REF,
7306 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7308 op_getmad(o,newop,'O');
7314 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7315 o->op_private |= OPpFT_ACCESS;
7316 if (PL_check[kidtype] == Perl_ck_ftst
7317 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7318 o->op_private |= OPpFT_STACKED;
7326 if (type == OP_FTTTY)
7327 o = newGVOP(type, OPf_REF, PL_stdingv);
7329 o = newUNOP(type, 0, newDEFSVOP());
7330 op_getmad(oldo,o,'O');
7336 Perl_ck_fun(pTHX_ OP *o)
7339 const int type = o->op_type;
7340 register I32 oa = PL_opargs[type] >> OASHIFT;
7342 PERL_ARGS_ASSERT_CK_FUN;
7344 if (o->op_flags & OPf_STACKED) {
7345 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7348 return no_fh_allowed(o);
7351 if (o->op_flags & OPf_KIDS) {
7352 OP **tokid = &cLISTOPo->op_first;
7353 register OP *kid = cLISTOPo->op_first;
7357 if (kid->op_type == OP_PUSHMARK ||
7358 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7360 tokid = &kid->op_sibling;
7361 kid = kid->op_sibling;
7363 if (!kid && PL_opargs[type] & OA_DEFGV)
7364 *tokid = kid = newDEFSVOP();
7368 sibl = kid->op_sibling;
7370 if (!sibl && kid->op_type == OP_STUB) {
7377 /* list seen where single (scalar) arg expected? */
7378 if (numargs == 1 && !(oa >> 4)
7379 && kid->op_type == OP_LIST && type != OP_SCALAR)
7381 return too_many_arguments(o,PL_op_desc[type]);
7394 if ((type == OP_PUSH || type == OP_UNSHIFT)
7395 && !kid->op_sibling)
7396 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7397 "Useless use of %s with no values",
7400 if (kid->op_type == OP_CONST &&
7401 (kid->op_private & OPpCONST_BARE))
7403 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7404 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7405 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7406 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7407 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7409 op_getmad(kid,newop,'K');
7414 kid->op_sibling = sibl;
7417 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7418 bad_type(numargs, "array", PL_op_desc[type], kid);
7422 if (kid->op_type == OP_CONST &&
7423 (kid->op_private & OPpCONST_BARE))
7425 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7426 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7427 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7428 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7429 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7431 op_getmad(kid,newop,'K');
7436 kid->op_sibling = sibl;
7439 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7440 bad_type(numargs, "hash", PL_op_desc[type], kid);
7445 OP * const newop = newUNOP(OP_NULL, 0, kid);
7446 kid->op_sibling = 0;
7448 newop->op_next = newop;
7450 kid->op_sibling = sibl;
7455 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7456 if (kid->op_type == OP_CONST &&
7457 (kid->op_private & OPpCONST_BARE))
7459 OP * const newop = newGVOP(OP_GV, 0,
7460 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7461 if (!(o->op_private & 1) && /* if not unop */
7462 kid == cLISTOPo->op_last)
7463 cLISTOPo->op_last = newop;
7465 op_getmad(kid,newop,'K');
7471 else if (kid->op_type == OP_READLINE) {
7472 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7473 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7476 I32 flags = OPf_SPECIAL;
7480 /* is this op a FH constructor? */
7481 if (is_handle_constructor(o,numargs)) {
7482 const char *name = NULL;
7486 /* Set a flag to tell rv2gv to vivify
7487 * need to "prove" flag does not mean something
7488 * else already - NI-S 1999/05/07
7491 if (kid->op_type == OP_PADSV) {
7493 = PAD_COMPNAME_SV(kid->op_targ);
7494 name = SvPV_const(namesv, len);
7496 else if (kid->op_type == OP_RV2SV
7497 && kUNOP->op_first->op_type == OP_GV)
7499 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7501 len = GvNAMELEN(gv);
7503 else if (kid->op_type == OP_AELEM
7504 || kid->op_type == OP_HELEM)
7507 OP *op = ((BINOP*)kid)->op_first;
7511 const char * const a =
7512 kid->op_type == OP_AELEM ?
7514 if (((op->op_type == OP_RV2AV) ||
7515 (op->op_type == OP_RV2HV)) &&
7516 (firstop = ((UNOP*)op)->op_first) &&
7517 (firstop->op_type == OP_GV)) {
7518 /* packagevar $a[] or $h{} */
7519 GV * const gv = cGVOPx_gv(firstop);
7527 else if (op->op_type == OP_PADAV
7528 || op->op_type == OP_PADHV) {
7529 /* lexicalvar $a[] or $h{} */
7530 const char * const padname =
7531 PAD_COMPNAME_PV(op->op_targ);
7540 name = SvPV_const(tmpstr, len);
7545 name = "__ANONIO__";
7552 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7553 namesv = PAD_SVl(targ);
7554 SvUPGRADE(namesv, SVt_PV);
7556 sv_setpvs(namesv, "$");
7557 sv_catpvn(namesv, name, len);
7560 kid->op_sibling = 0;
7561 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7562 kid->op_targ = targ;
7563 kid->op_private |= priv;
7565 kid->op_sibling = sibl;
7571 mod(scalar(kid), type);
7575 tokid = &kid->op_sibling;
7576 kid = kid->op_sibling;
7579 if (kid && kid->op_type != OP_STUB)
7580 return too_many_arguments(o,OP_DESC(o));
7581 o->op_private |= numargs;
7583 /* FIXME - should the numargs move as for the PERL_MAD case? */
7584 o->op_private |= numargs;
7586 return too_many_arguments(o,OP_DESC(o));
7590 else if (PL_opargs[type] & OA_DEFGV) {
7592 OP *newop = newUNOP(type, 0, newDEFSVOP());
7593 op_getmad(o,newop,'O');
7596 /* Ordering of these two is important to keep f_map.t passing. */
7598 return newUNOP(type, 0, newDEFSVOP());
7603 while (oa & OA_OPTIONAL)
7605 if (oa && oa != OA_LIST)
7606 return too_few_arguments(o,OP_DESC(o));
7612 Perl_ck_glob(pTHX_ OP *o)
7617 PERL_ARGS_ASSERT_CK_GLOB;
7620 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7621 op_append_elem(OP_GLOB, o, newDEFSVOP());
7623 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7624 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7626 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7629 #if !defined(PERL_EXTERNAL_GLOB)
7630 /* XXX this can be tightened up and made more failsafe. */
7631 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7634 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7635 newSVpvs("File::Glob"), NULL, NULL, NULL);
7636 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7637 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7638 GvCV(gv) = GvCV(glob_gv);
7639 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7640 GvIMPORTED_CV_on(gv);
7644 #endif /* PERL_EXTERNAL_GLOB */
7646 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7647 op_append_elem(OP_GLOB, o,
7648 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7649 o->op_type = OP_LIST;
7650 o->op_ppaddr = PL_ppaddr[OP_LIST];
7651 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7652 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7653 cLISTOPo->op_first->op_targ = 0;
7654 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7655 op_append_elem(OP_LIST, o,
7656 scalar(newUNOP(OP_RV2CV, 0,
7657 newGVOP(OP_GV, 0, gv)))));
7658 o = newUNOP(OP_NULL, 0, ck_subr(o));
7659 o->op_targ = OP_GLOB; /* hint at what it used to be */
7662 gv = newGVgen("main");
7664 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7670 Perl_ck_grep(pTHX_ OP *o)
7675 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7678 PERL_ARGS_ASSERT_CK_GREP;
7680 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7681 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7683 if (o->op_flags & OPf_STACKED) {
7686 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7687 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7688 return no_fh_allowed(o);
7689 for (k = kid; k; k = k->op_next) {
7692 NewOp(1101, gwop, 1, LOGOP);
7693 kid->op_next = (OP*)gwop;
7694 o->op_flags &= ~OPf_STACKED;
7696 kid = cLISTOPo->op_first->op_sibling;
7697 if (type == OP_MAPWHILE)
7702 if (PL_parser && PL_parser->error_count)
7704 kid = cLISTOPo->op_first->op_sibling;
7705 if (kid->op_type != OP_NULL)
7706 Perl_croak(aTHX_ "panic: ck_grep");
7707 kid = kUNOP->op_first;
7710 NewOp(1101, gwop, 1, LOGOP);
7711 gwop->op_type = type;
7712 gwop->op_ppaddr = PL_ppaddr[type];
7713 gwop->op_first = listkids(o);
7714 gwop->op_flags |= OPf_KIDS;
7715 gwop->op_other = LINKLIST(kid);
7716 kid->op_next = (OP*)gwop;
7717 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7718 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7719 o->op_private = gwop->op_private = 0;
7720 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7723 o->op_private = gwop->op_private = OPpGREP_LEX;
7724 gwop->op_targ = o->op_targ = offset;
7727 kid = cLISTOPo->op_first->op_sibling;
7728 if (!kid || !kid->op_sibling)
7729 return too_few_arguments(o,OP_DESC(o));
7730 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7731 mod(kid, OP_GREPSTART);
7737 Perl_ck_index(pTHX_ OP *o)
7739 PERL_ARGS_ASSERT_CK_INDEX;
7741 if (o->op_flags & OPf_KIDS) {
7742 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7744 kid = kid->op_sibling; /* get past "big" */
7745 if (kid && kid->op_type == OP_CONST)
7746 fbm_compile(((SVOP*)kid)->op_sv, 0);
7752 Perl_ck_lfun(pTHX_ OP *o)
7754 const OPCODE type = o->op_type;
7756 PERL_ARGS_ASSERT_CK_LFUN;
7758 return modkids(ck_fun(o), type);
7762 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7764 PERL_ARGS_ASSERT_CK_DEFINED;
7766 if ((o->op_flags & OPf_KIDS)) {
7767 switch (cUNOPo->op_first->op_type) {
7769 /* This is needed for
7770 if (defined %stash::)
7771 to work. Do not break Tk.
7773 break; /* Globals via GV can be undef */
7775 case OP_AASSIGN: /* Is this a good idea? */
7776 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7777 "defined(@array) is deprecated");
7778 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7779 "\t(Maybe you should just omit the defined()?)\n");
7783 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7784 "defined(%%hash) is deprecated");
7785 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7786 "\t(Maybe you should just omit the defined()?)\n");
7797 Perl_ck_readline(pTHX_ OP *o)
7799 PERL_ARGS_ASSERT_CK_READLINE;
7801 if (!(o->op_flags & OPf_KIDS)) {
7803 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7805 op_getmad(o,newop,'O');
7815 Perl_ck_rfun(pTHX_ OP *o)
7817 const OPCODE type = o->op_type;
7819 PERL_ARGS_ASSERT_CK_RFUN;
7821 return refkids(ck_fun(o), type);
7825 Perl_ck_listiob(pTHX_ OP *o)
7829 PERL_ARGS_ASSERT_CK_LISTIOB;
7831 kid = cLISTOPo->op_first;
7834 kid = cLISTOPo->op_first;
7836 if (kid->op_type == OP_PUSHMARK)
7837 kid = kid->op_sibling;
7838 if (kid && o->op_flags & OPf_STACKED)
7839 kid = kid->op_sibling;
7840 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7841 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7842 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7843 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7844 cLISTOPo->op_first->op_sibling = kid;
7845 cLISTOPo->op_last = kid;
7846 kid = kid->op_sibling;
7851 op_append_elem(o->op_type, o, newDEFSVOP());
7857 Perl_ck_smartmatch(pTHX_ OP *o)
7860 PERL_ARGS_ASSERT_CK_SMARTMATCH;
7861 if (0 == (o->op_flags & OPf_SPECIAL)) {
7862 OP *first = cBINOPo->op_first;
7863 OP *second = first->op_sibling;
7865 /* Implicitly take a reference to an array or hash */
7866 first->op_sibling = NULL;
7867 first = cBINOPo->op_first = ref_array_or_hash(first);
7868 second = first->op_sibling = ref_array_or_hash(second);
7870 /* Implicitly take a reference to a regular expression */
7871 if (first->op_type == OP_MATCH) {
7872 first->op_type = OP_QR;
7873 first->op_ppaddr = PL_ppaddr[OP_QR];
7875 if (second->op_type == OP_MATCH) {
7876 second->op_type = OP_QR;
7877 second->op_ppaddr = PL_ppaddr[OP_QR];
7886 Perl_ck_sassign(pTHX_ OP *o)
7889 OP * const kid = cLISTOPo->op_first;
7891 PERL_ARGS_ASSERT_CK_SASSIGN;
7893 /* has a disposable target? */
7894 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7895 && !(kid->op_flags & OPf_STACKED)
7896 /* Cannot steal the second time! */
7897 && !(kid->op_private & OPpTARGET_MY)
7898 /* Keep the full thing for madskills */
7902 OP * const kkid = kid->op_sibling;
7904 /* Can just relocate the target. */
7905 if (kkid && kkid->op_type == OP_PADSV
7906 && !(kkid->op_private & OPpLVAL_INTRO))
7908 kid->op_targ = kkid->op_targ;
7910 /* Now we do not need PADSV and SASSIGN. */
7911 kid->op_sibling = o->op_sibling; /* NULL */
7912 cLISTOPo->op_first = NULL;
7915 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7919 if (kid->op_sibling) {
7920 OP *kkid = kid->op_sibling;
7921 if (kkid->op_type == OP_PADSV
7922 && (kkid->op_private & OPpLVAL_INTRO)
7923 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7924 const PADOFFSET target = kkid->op_targ;
7925 OP *const other = newOP(OP_PADSV,
7927 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7928 OP *const first = newOP(OP_NULL, 0);
7929 OP *const nullop = newCONDOP(0, first, o, other);
7930 OP *const condop = first->op_next;
7931 /* hijacking PADSTALE for uninitialized state variables */
7932 SvPADSTALE_on(PAD_SVl(target));
7934 condop->op_type = OP_ONCE;
7935 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7936 condop->op_targ = target;
7937 other->op_targ = target;
7939 /* Because we change the type of the op here, we will skip the
7940 assinment binop->op_last = binop->op_first->op_sibling; at the
7941 end of Perl_newBINOP(). So need to do it here. */
7942 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7951 Perl_ck_match(pTHX_ OP *o)
7955 PERL_ARGS_ASSERT_CK_MATCH;
7957 if (o->op_type != OP_QR && PL_compcv) {
7958 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7959 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7960 o->op_targ = offset;
7961 o->op_private |= OPpTARGET_MY;
7964 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7965 o->op_private |= OPpRUNTIME;
7970 Perl_ck_method(pTHX_ OP *o)
7972 OP * const kid = cUNOPo->op_first;
7974 PERL_ARGS_ASSERT_CK_METHOD;
7976 if (kid->op_type == OP_CONST) {
7977 SV* sv = kSVOP->op_sv;
7978 const char * const method = SvPVX_const(sv);
7979 if (!(strchr(method, ':') || strchr(method, '\''))) {
7981 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7982 sv = newSVpvn_share(method, SvCUR(sv), 0);
7985 kSVOP->op_sv = NULL;
7987 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7989 op_getmad(o,cmop,'O');
8000 Perl_ck_null(pTHX_ OP *o)
8002 PERL_ARGS_ASSERT_CK_NULL;
8003 PERL_UNUSED_CONTEXT;
8008 Perl_ck_open(pTHX_ OP *o)
8011 HV * const table = GvHV(PL_hintgv);
8013 PERL_ARGS_ASSERT_CK_OPEN;
8016 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8019 const char *d = SvPV_const(*svp, len);
8020 const I32 mode = mode_from_discipline(d, len);
8021 if (mode & O_BINARY)
8022 o->op_private |= OPpOPEN_IN_RAW;
8023 else if (mode & O_TEXT)
8024 o->op_private |= OPpOPEN_IN_CRLF;
8027 svp = hv_fetchs(table, "open_OUT", FALSE);
8030 const char *d = SvPV_const(*svp, len);
8031 const I32 mode = mode_from_discipline(d, len);
8032 if (mode & O_BINARY)
8033 o->op_private |= OPpOPEN_OUT_RAW;
8034 else if (mode & O_TEXT)
8035 o->op_private |= OPpOPEN_OUT_CRLF;
8038 if (o->op_type == OP_BACKTICK) {
8039 if (!(o->op_flags & OPf_KIDS)) {
8040 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8042 op_getmad(o,newop,'O');
8051 /* In case of three-arg dup open remove strictness
8052 * from the last arg if it is a bareword. */
8053 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8054 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8058 if ((last->op_type == OP_CONST) && /* The bareword. */
8059 (last->op_private & OPpCONST_BARE) &&
8060 (last->op_private & OPpCONST_STRICT) &&
8061 (oa = first->op_sibling) && /* The fh. */
8062 (oa = oa->op_sibling) && /* The mode. */
8063 (oa->op_type == OP_CONST) &&
8064 SvPOK(((SVOP*)oa)->op_sv) &&
8065 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8066 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8067 (last == oa->op_sibling)) /* The bareword. */
8068 last->op_private &= ~OPpCONST_STRICT;
8074 Perl_ck_repeat(pTHX_ OP *o)
8076 PERL_ARGS_ASSERT_CK_REPEAT;
8078 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8079 o->op_private |= OPpREPEAT_DOLIST;
8080 cBINOPo->op_first = force_list(cBINOPo->op_first);
8088 Perl_ck_require(pTHX_ OP *o)
8093 PERL_ARGS_ASSERT_CK_REQUIRE;
8095 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8096 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8098 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8099 SV * const sv = kid->op_sv;
8100 U32 was_readonly = SvREADONLY(sv);
8107 sv_force_normal_flags(sv, 0);
8108 assert(!SvREADONLY(sv));
8118 for (; s < end; s++) {
8119 if (*s == ':' && s[1] == ':') {
8121 Move(s+2, s+1, end - s - 1, char);
8126 sv_catpvs(sv, ".pm");
8127 SvFLAGS(sv) |= was_readonly;
8131 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8132 /* handle override, if any */
8133 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8134 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8135 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8136 gv = gvp ? *gvp : NULL;
8140 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8141 OP * const kid = cUNOPo->op_first;
8144 cUNOPo->op_first = 0;
8148 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8149 op_append_elem(OP_LIST, kid,
8150 scalar(newUNOP(OP_RV2CV, 0,
8153 op_getmad(o,newop,'O');
8157 return scalar(ck_fun(o));
8161 Perl_ck_return(pTHX_ OP *o)
8166 PERL_ARGS_ASSERT_CK_RETURN;
8168 kid = cLISTOPo->op_first->op_sibling;
8169 if (CvLVALUE(PL_compcv)) {
8170 for (; kid; kid = kid->op_sibling)
8171 mod(kid, OP_LEAVESUBLV);
8173 for (; kid; kid = kid->op_sibling)
8174 if ((kid->op_type == OP_NULL)
8175 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8176 /* This is a do block */
8177 OP *op = kUNOP->op_first;
8178 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8179 op = cUNOPx(op)->op_first;
8180 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8181 /* Force the use of the caller's context */
8182 op->op_flags |= OPf_SPECIAL;
8191 Perl_ck_select(pTHX_ OP *o)
8196 PERL_ARGS_ASSERT_CK_SELECT;
8198 if (o->op_flags & OPf_KIDS) {
8199 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8200 if (kid && kid->op_sibling) {
8201 o->op_type = OP_SSELECT;
8202 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8204 return fold_constants(o);
8208 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8209 if (kid && kid->op_type == OP_RV2GV)
8210 kid->op_private &= ~HINT_STRICT_REFS;
8215 Perl_ck_shift(pTHX_ OP *o)
8218 const I32 type = o->op_type;
8220 PERL_ARGS_ASSERT_CK_SHIFT;
8222 if (!(o->op_flags & OPf_KIDS)) {
8225 if (!CvUNIQUE(PL_compcv)) {
8226 o->op_flags |= OPf_SPECIAL;
8230 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8233 OP * const oldo = o;
8234 o = newUNOP(type, 0, scalar(argop));
8235 op_getmad(oldo,o,'O');
8240 return newUNOP(type, 0, scalar(argop));
8243 return scalar(modkids(ck_fun(o), type));
8247 Perl_ck_sort(pTHX_ OP *o)
8252 PERL_ARGS_ASSERT_CK_SORT;
8254 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8255 HV * const hinthv = GvHV(PL_hintgv);
8257 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8259 const I32 sorthints = (I32)SvIV(*svp);
8260 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8261 o->op_private |= OPpSORT_QSORT;
8262 if ((sorthints & HINT_SORT_STABLE) != 0)
8263 o->op_private |= OPpSORT_STABLE;
8268 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8270 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8271 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8273 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8275 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8277 if (kid->op_type == OP_SCOPE) {
8281 else if (kid->op_type == OP_LEAVE) {
8282 if (o->op_type == OP_SORT) {
8283 op_null(kid); /* wipe out leave */
8286 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8287 if (k->op_next == kid)
8289 /* don't descend into loops */
8290 else if (k->op_type == OP_ENTERLOOP
8291 || k->op_type == OP_ENTERITER)
8293 k = cLOOPx(k)->op_lastop;
8298 kid->op_next = 0; /* just disconnect the leave */
8299 k = kLISTOP->op_first;
8304 if (o->op_type == OP_SORT) {
8305 /* provide scalar context for comparison function/block */
8311 o->op_flags |= OPf_SPECIAL;
8313 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8316 firstkid = firstkid->op_sibling;
8319 /* provide list context for arguments */
8320 if (o->op_type == OP_SORT)
8327 S_simplify_sort(pTHX_ OP *o)
8330 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8336 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8338 if (!(o->op_flags & OPf_STACKED))
8340 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8341 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8342 kid = kUNOP->op_first; /* get past null */
8343 if (kid->op_type != OP_SCOPE)
8345 kid = kLISTOP->op_last; /* get past scope */
8346 switch(kid->op_type) {
8354 k = kid; /* remember this node*/
8355 if (kBINOP->op_first->op_type != OP_RV2SV)
8357 kid = kBINOP->op_first; /* get past cmp */
8358 if (kUNOP->op_first->op_type != OP_GV)
8360 kid = kUNOP->op_first; /* get past rv2sv */
8362 if (GvSTASH(gv) != PL_curstash)
8364 gvname = GvNAME(gv);
8365 if (*gvname == 'a' && gvname[1] == '\0')
8367 else if (*gvname == 'b' && gvname[1] == '\0')
8372 kid = k; /* back to cmp */
8373 if (kBINOP->op_last->op_type != OP_RV2SV)
8375 kid = kBINOP->op_last; /* down to 2nd arg */
8376 if (kUNOP->op_first->op_type != OP_GV)
8378 kid = kUNOP->op_first; /* get past rv2sv */
8380 if (GvSTASH(gv) != PL_curstash)
8382 gvname = GvNAME(gv);
8384 ? !(*gvname == 'a' && gvname[1] == '\0')
8385 : !(*gvname == 'b' && gvname[1] == '\0'))
8387 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8389 o->op_private |= OPpSORT_DESCEND;
8390 if (k->op_type == OP_NCMP)
8391 o->op_private |= OPpSORT_NUMERIC;
8392 if (k->op_type == OP_I_NCMP)
8393 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8394 kid = cLISTOPo->op_first->op_sibling;
8395 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8397 op_getmad(kid,o,'S'); /* then delete it */
8399 op_free(kid); /* then delete it */
8404 Perl_ck_split(pTHX_ OP *o)
8409 PERL_ARGS_ASSERT_CK_SPLIT;
8411 if (o->op_flags & OPf_STACKED)
8412 return no_fh_allowed(o);
8414 kid = cLISTOPo->op_first;
8415 if (kid->op_type != OP_NULL)
8416 Perl_croak(aTHX_ "panic: ck_split");
8417 kid = kid->op_sibling;
8418 op_free(cLISTOPo->op_first);
8419 cLISTOPo->op_first = kid;
8421 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8422 cLISTOPo->op_last = kid; /* There was only one element previously */
8425 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8426 OP * const sibl = kid->op_sibling;
8427 kid->op_sibling = 0;
8428 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8429 if (cLISTOPo->op_first == cLISTOPo->op_last)
8430 cLISTOPo->op_last = kid;
8431 cLISTOPo->op_first = kid;
8432 kid->op_sibling = sibl;
8435 kid->op_type = OP_PUSHRE;
8436 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8438 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8439 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8440 "Use of /g modifier is meaningless in split");
8443 if (!kid->op_sibling)
8444 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8446 kid = kid->op_sibling;
8449 if (!kid->op_sibling)
8450 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8451 assert(kid->op_sibling);
8453 kid = kid->op_sibling;
8456 if (kid->op_sibling)
8457 return too_many_arguments(o,OP_DESC(o));
8463 Perl_ck_join(pTHX_ OP *o)
8465 const OP * const kid = cLISTOPo->op_first->op_sibling;
8467 PERL_ARGS_ASSERT_CK_JOIN;
8469 if (kid && kid->op_type == OP_MATCH) {
8470 if (ckWARN(WARN_SYNTAX)) {
8471 const REGEXP *re = PM_GETRE(kPMOP);
8472 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8473 const STRLEN len = re ? RX_PRELEN(re) : 6;
8474 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8475 "/%.*s/ should probably be written as \"%.*s\"",
8476 (int)len, pmstr, (int)len, pmstr);
8483 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8485 Examines an op, which is expected to identify a subroutine at runtime,
8486 and attempts to determine at compile time which subroutine it identifies.
8487 This is normally used during Perl compilation to determine whether
8488 a prototype can be applied to a function call. I<cvop> is the op
8489 being considered, normally an C<rv2cv> op. A pointer to the identified
8490 subroutine is returned, if it could be determined statically, and a null
8491 pointer is returned if it was not possible to determine statically.
8493 Currently, the subroutine can be identified statically if the RV that the
8494 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8495 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
8496 suitable if the constant value must be an RV pointing to a CV. Details of
8497 this process may change in future versions of Perl. If the C<rv2cv> op
8498 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8499 the subroutine statically: this flag is used to suppress compile-time
8500 magic on a subroutine call, forcing it to use default runtime behaviour.
8502 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8503 of a GV reference is modified. If a GV was examined and its CV slot was
8504 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8505 If the op is not optimised away, and the CV slot is later populated with
8506 a subroutine having a prototype, that flag eventually triggers the warning
8507 "called too early to check prototype".
8509 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8510 of returning a pointer to the subroutine it returns a pointer to the
8511 GV giving the most appropriate name for the subroutine in this context.
8512 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8513 (C<CvANON>) subroutine that is referenced through a GV it will be the
8514 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
8515 A null pointer is returned as usual if there is no statically-determinable
8522 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8527 PERL_ARGS_ASSERT_RV2CV_OP_CV;
8528 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8529 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8530 if (cvop->op_type != OP_RV2CV)
8532 if (cvop->op_private & OPpENTERSUB_AMPER)
8534 if (!(cvop->op_flags & OPf_KIDS))
8536 rvop = cUNOPx(cvop)->op_first;
8537 switch (rvop->op_type) {
8539 gv = cGVOPx_gv(rvop);
8542 if (flags & RV2CVOPCV_MARK_EARLY)
8543 rvop->op_private |= OPpEARLY_CV;
8548 SV *rv = cSVOPx_sv(rvop);
8558 if (SvTYPE((SV*)cv) != SVt_PVCV)
8560 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8561 if (!CvANON(cv) || !gv)
8570 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8572 Performs the default fixup of the arguments part of an C<entersub>
8573 op tree. This consists of applying list context to each of the
8574 argument ops. This is the standard treatment used on a call marked
8575 with C<&>, or a method call, or a call through a subroutine reference,
8576 or any other call where the callee can't be identified at compile time,
8577 or a call where the callee has no prototype.
8583 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8586 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8587 aop = cUNOPx(entersubop)->op_first;
8588 if (!aop->op_sibling)
8589 aop = cUNOPx(aop)->op_first;
8590 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8591 if (!(PL_madskills && aop->op_type == OP_STUB)) {
8593 mod(aop, OP_ENTERSUB);
8600 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8602 Performs the fixup of the arguments part of an C<entersub> op tree
8603 based on a subroutine prototype. This makes various modifications to
8604 the argument ops, from applying context up to inserting C<refgen> ops,
8605 and checking the number and syntactic types of arguments, as directed by
8606 the prototype. This is the standard treatment used on a subroutine call,
8607 not marked with C<&>, where the callee can be identified at compile time
8608 and has a prototype.
8610 I<protosv> supplies the subroutine prototype to be applied to the call.
8611 It may be a normal defined scalar, of which the string value will be used.
8612 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8613 that has been cast to C<SV*>) which has a prototype. The prototype
8614 supplied, in whichever form, does not need to match the actual callee
8615 referenced by the op tree.
8617 If the argument ops disagree with the prototype, for example by having
8618 an unacceptable number of arguments, a valid op tree is returned anyway.
8619 The error is reflected in the parser state, normally resulting in a single
8620 exception at the top level of parsing which covers all the compilation
8621 errors that occurred. In the error message, the callee is referred to
8622 by the name defined by the I<namegv> parameter.
8628 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8631 const char *proto, *proto_end;
8632 OP *aop, *prev, *cvop;
8635 I32 contextclass = 0;
8636 const char *e = NULL;
8637 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8638 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8639 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8640 proto = SvPV(protosv, proto_len);
8641 proto_end = proto + proto_len;
8642 aop = cUNOPx(entersubop)->op_first;
8643 if (!aop->op_sibling)
8644 aop = cUNOPx(aop)->op_first;
8646 aop = aop->op_sibling;
8647 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8648 while (aop != cvop) {
8650 if (PL_madskills && aop->op_type == OP_STUB) {
8651 aop = aop->op_sibling;
8654 if (PL_madskills && aop->op_type == OP_NULL)
8655 o3 = ((UNOP*)aop)->op_first;
8659 if (proto >= proto_end)
8660 return too_many_arguments(entersubop, gv_ename(namegv));
8668 /* _ must be at the end */
8669 if (proto[1] && proto[1] != ';')
8684 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8686 arg == 1 ? "block or sub {}" : "sub {}",
8687 gv_ename(namegv), o3);
8690 /* '*' allows any scalar type, including bareword */
8693 if (o3->op_type == OP_RV2GV)
8694 goto wrapref; /* autoconvert GLOB -> GLOBref */
8695 else if (o3->op_type == OP_CONST)
8696 o3->op_private &= ~OPpCONST_STRICT;
8697 else if (o3->op_type == OP_ENTERSUB) {
8698 /* accidental subroutine, revert to bareword */
8699 OP *gvop = ((UNOP*)o3)->op_first;
8700 if (gvop && gvop->op_type == OP_NULL) {
8701 gvop = ((UNOP*)gvop)->op_first;
8703 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8706 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8707 (gvop = ((UNOP*)gvop)->op_first) &&
8708 gvop->op_type == OP_GV)
8710 GV * const gv = cGVOPx_gv(gvop);
8711 OP * const sibling = aop->op_sibling;
8712 SV * const n = newSVpvs("");
8714 OP * const oldaop = aop;
8718 gv_fullname4(n, gv, "", FALSE);
8719 aop = newSVOP(OP_CONST, 0, n);
8720 op_getmad(oldaop,aop,'O');
8721 prev->op_sibling = aop;
8722 aop->op_sibling = sibling;
8732 if (o3->op_type == OP_RV2AV ||
8733 o3->op_type == OP_PADAV ||
8734 o3->op_type == OP_RV2HV ||
8735 o3->op_type == OP_PADHV
8750 if (contextclass++ == 0) {
8751 e = strchr(proto, ']');
8752 if (!e || e == proto)
8761 const char *p = proto;
8762 const char *const end = proto;
8764 while (*--p != '[') {}
8765 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8767 gv_ename(namegv), o3);
8772 if (o3->op_type == OP_RV2GV)
8775 bad_type(arg, "symbol", gv_ename(namegv), o3);
8778 if (o3->op_type == OP_ENTERSUB)
8781 bad_type(arg, "subroutine entry", gv_ename(namegv),
8785 if (o3->op_type == OP_RV2SV ||
8786 o3->op_type == OP_PADSV ||
8787 o3->op_type == OP_HELEM ||
8788 o3->op_type == OP_AELEM)
8791 bad_type(arg, "scalar", gv_ename(namegv), o3);
8794 if (o3->op_type == OP_RV2AV ||
8795 o3->op_type == OP_PADAV)
8798 bad_type(arg, "array", gv_ename(namegv), o3);
8801 if (o3->op_type == OP_RV2HV ||
8802 o3->op_type == OP_PADHV)
8805 bad_type(arg, "hash", gv_ename(namegv), o3);
8809 OP* const kid = aop;
8810 OP* const sib = kid->op_sibling;
8811 kid->op_sibling = 0;
8812 aop = newUNOP(OP_REFGEN, 0, kid);
8813 aop->op_sibling = sib;
8814 prev->op_sibling = aop;
8816 if (contextclass && e) {
8831 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8832 gv_ename(namegv), SVfARG(protosv));
8835 mod(aop, OP_ENTERSUB);
8837 aop = aop->op_sibling;
8839 if (aop == cvop && *proto == '_') {
8840 /* generate an access to $_ */
8842 aop->op_sibling = prev->op_sibling;
8843 prev->op_sibling = aop; /* instead of cvop */
8845 if (!optional && proto_end > proto &&
8846 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8847 return too_few_arguments(entersubop, gv_ename(namegv));
8852 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8854 Performs the fixup of the arguments part of an C<entersub> op tree either
8855 based on a subroutine prototype or using default list-context processing.
8856 This is the standard treatment used on a subroutine call, not marked
8857 with C<&>, where the callee can be identified at compile time.
8859 I<protosv> supplies the subroutine prototype to be applied to the call,
8860 or indicates that there is no prototype. It may be a normal scalar,
8861 in which case if it is defined then the string value will be used
8862 as a prototype, and if it is undefined then there is no prototype.
8863 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8864 that has been cast to C<SV*>), of which the prototype will be used if it
8865 has one. The prototype (or lack thereof) supplied, in whichever form,
8866 does not need to match the actual callee referenced by the op tree.
8868 If the argument ops disagree with the prototype, for example by having
8869 an unacceptable number of arguments, a valid op tree is returned anyway.
8870 The error is reflected in the parser state, normally resulting in a single
8871 exception at the top level of parsing which covers all the compilation
8872 errors that occurred. In the error message, the callee is referred to
8873 by the name defined by the I<namegv> parameter.
8879 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8880 GV *namegv, SV *protosv)
8882 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8883 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8884 return ck_entersub_args_proto(entersubop, namegv, protosv);
8886 return ck_entersub_args_list(entersubop);
8890 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8892 Retrieves the function that will be used to fix up a call to I<cv>.
8893 Specifically, the function is applied to an C<entersub> op tree for a
8894 subroutine call, not marked with C<&>, where the callee can be identified
8895 at compile time as I<cv>.
8897 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8898 argument for it is returned in I<*ckobj_p>. The function is intended
8899 to be called in this manner:
8901 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8903 In this call, I<entersubop> is a pointer to the C<entersub> op,
8904 which may be replaced by the check function, and I<namegv> is a GV
8905 supplying the name that should be used by the check function to refer
8906 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8907 It is permitted to apply the check function in non-standard situations,
8908 such as to a call to a different subroutine or to a method call.
8910 By default, the function is
8911 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8912 and the SV parameter is I<cv> itself. This implements standard
8913 prototype processing. It can be changed, for a particular subroutine,
8914 by L</cv_set_call_checker>.
8920 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8923 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8924 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8926 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8927 *ckobj_p = callmg->mg_obj;
8929 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8935 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8937 Sets the function that will be used to fix up a call to I<cv>.
8938 Specifically, the function is applied to an C<entersub> op tree for a
8939 subroutine call, not marked with C<&>, where the callee can be identified
8940 at compile time as I<cv>.
8942 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8943 for it is supplied in I<ckobj>. The function is intended to be called
8946 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8948 In this call, I<entersubop> is a pointer to the C<entersub> op,
8949 which may be replaced by the check function, and I<namegv> is a GV
8950 supplying the name that should be used by the check function to refer
8951 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8952 It is permitted to apply the check function in non-standard situations,
8953 such as to a call to a different subroutine or to a method call.
8955 The current setting for a particular CV can be retrieved by
8956 L</cv_get_call_checker>.
8962 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8964 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8965 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8966 if (SvMAGICAL((SV*)cv))
8967 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8970 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8971 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8972 if (callmg->mg_flags & MGf_REFCOUNTED) {
8973 SvREFCNT_dec(callmg->mg_obj);
8974 callmg->mg_flags &= ~MGf_REFCOUNTED;
8976 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8977 callmg->mg_obj = ckobj;
8978 if (ckobj != (SV*)cv) {
8979 SvREFCNT_inc_simple_void_NN(ckobj);
8980 callmg->mg_flags |= MGf_REFCOUNTED;
8986 Perl_ck_subr(pTHX_ OP *o)
8992 PERL_ARGS_ASSERT_CK_SUBR;
8994 aop = cUNOPx(o)->op_first;
8995 if (!aop->op_sibling)
8996 aop = cUNOPx(aop)->op_first;
8997 aop = aop->op_sibling;
8998 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8999 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9000 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9002 o->op_private |= OPpENTERSUB_HASTARG;
9003 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9004 if (PERLDB_SUB && PL_curstash != PL_debstash)
9005 o->op_private |= OPpENTERSUB_DB;
9006 if (cvop->op_type == OP_RV2CV) {
9007 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9009 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9010 if (aop->op_type == OP_CONST)
9011 aop->op_private &= ~OPpCONST_STRICT;
9012 else if (aop->op_type == OP_LIST) {
9013 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9014 if (sib && sib->op_type == OP_CONST)
9015 sib->op_private &= ~OPpCONST_STRICT;
9020 return ck_entersub_args_list(o);
9022 Perl_call_checker ckfun;
9024 cv_get_call_checker(cv, &ckfun, &ckobj);
9025 return ckfun(aTHX_ o, namegv, ckobj);
9030 Perl_ck_svconst(pTHX_ OP *o)
9032 PERL_ARGS_ASSERT_CK_SVCONST;
9033 PERL_UNUSED_CONTEXT;
9034 SvREADONLY_on(cSVOPo->op_sv);
9039 Perl_ck_chdir(pTHX_ OP *o)
9041 PERL_ARGS_ASSERT_CK_CHDIR;
9042 if (o->op_flags & OPf_KIDS) {
9043 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9045 if (kid && kid->op_type == OP_CONST &&
9046 (kid->op_private & OPpCONST_BARE))
9048 o->op_flags |= OPf_SPECIAL;
9049 kid->op_private &= ~OPpCONST_STRICT;
9056 Perl_ck_trunc(pTHX_ OP *o)
9058 PERL_ARGS_ASSERT_CK_TRUNC;
9060 if (o->op_flags & OPf_KIDS) {
9061 SVOP *kid = (SVOP*)cUNOPo->op_first;
9063 if (kid->op_type == OP_NULL)
9064 kid = (SVOP*)kid->op_sibling;
9065 if (kid && kid->op_type == OP_CONST &&
9066 (kid->op_private & OPpCONST_BARE))
9068 o->op_flags |= OPf_SPECIAL;
9069 kid->op_private &= ~OPpCONST_STRICT;
9076 Perl_ck_unpack(pTHX_ OP *o)
9078 OP *kid = cLISTOPo->op_first;
9080 PERL_ARGS_ASSERT_CK_UNPACK;
9082 if (kid->op_sibling) {
9083 kid = kid->op_sibling;
9084 if (!kid->op_sibling)
9085 kid->op_sibling = newDEFSVOP();
9091 Perl_ck_substr(pTHX_ OP *o)
9093 PERL_ARGS_ASSERT_CK_SUBSTR;
9096 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9097 OP *kid = cLISTOPo->op_first;
9099 if (kid->op_type == OP_NULL)
9100 kid = kid->op_sibling;
9102 kid->op_flags |= OPf_MOD;
9109 Perl_ck_each(pTHX_ OP *o)
9112 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9114 PERL_ARGS_ASSERT_CK_EACH;
9117 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
9118 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
9119 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9120 o->op_type = new_type;
9121 o->op_ppaddr = PL_ppaddr[new_type];
9123 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
9124 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
9126 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
9133 /* caller is supposed to assign the return to the
9134 container of the rep_op var */
9136 S_opt_scalarhv(pTHX_ OP *rep_op) {
9140 PERL_ARGS_ASSERT_OPT_SCALARHV;
9142 NewOp(1101, unop, 1, UNOP);
9143 unop->op_type = (OPCODE)OP_BOOLKEYS;
9144 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9145 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9146 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9147 unop->op_first = rep_op;
9148 unop->op_next = rep_op->op_next;
9149 rep_op->op_next = (OP*)unop;
9150 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9151 unop->op_sibling = rep_op->op_sibling;
9152 rep_op->op_sibling = NULL;
9153 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9154 if (rep_op->op_type == OP_PADHV) {
9155 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9156 rep_op->op_flags |= OPf_WANT_LIST;
9161 /* Checks if o acts as an in-place operator on an array. oright points to the
9162 * beginning of the right-hand side. Returns the left-hand side of the
9163 * assignment if o acts in-place, or NULL otherwise. */
9166 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9170 PERL_ARGS_ASSERT_IS_INPLACE_AV;
9173 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9174 || oright->op_next != o
9175 || (oright->op_private & OPpLVAL_INTRO)
9179 /* o2 follows the chain of op_nexts through the LHS of the
9180 * assign (if any) to the aassign op itself */
9182 if (!o2 || o2->op_type != OP_NULL)
9185 if (!o2 || o2->op_type != OP_PUSHMARK)
9188 if (o2 && o2->op_type == OP_GV)
9191 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9192 || (o2->op_private & OPpLVAL_INTRO)
9197 if (!o2 || o2->op_type != OP_NULL)
9200 if (!o2 || o2->op_type != OP_AASSIGN
9201 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9204 /* check that the sort is the first arg on RHS of assign */
9206 o2 = cUNOPx(o2)->op_first;
9207 if (!o2 || o2->op_type != OP_NULL)
9209 o2 = cUNOPx(o2)->op_first;
9210 if (!o2 || o2->op_type != OP_PUSHMARK)
9212 if (o2->op_sibling != o)
9215 /* check the array is the same on both sides */
9216 if (oleft->op_type == OP_RV2AV) {
9217 if (oright->op_type != OP_RV2AV
9218 || !cUNOPx(oright)->op_first
9219 || cUNOPx(oright)->op_first->op_type != OP_GV
9220 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9221 cGVOPx_gv(cUNOPx(oright)->op_first)
9225 else if (oright->op_type != OP_PADAV
9226 || oright->op_targ != oleft->op_targ
9233 /* A peephole optimizer. We visit the ops in the order they're to execute.
9234 * See the comments at the top of this file for more details about when
9235 * peep() is called */
9238 Perl_rpeep(pTHX_ register OP *o)
9241 register OP* oldop = NULL;
9243 if (!o || o->op_opt)
9247 SAVEVPTR(PL_curcop);
9248 for (; o; o = o->op_next) {
9251 /* By default, this op has now been optimised. A couple of cases below
9252 clear this again. */
9255 switch (o->op_type) {
9257 PL_curcop = ((COP*)o); /* for warnings */
9260 PL_curcop = ((COP*)o); /* for warnings */
9262 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9263 to carry two labels. For now, take the easier option, and skip
9264 this optimisation if the first NEXTSTATE has a label. */
9265 if (!CopLABEL((COP*)o)) {
9266 OP *nextop = o->op_next;
9267 while (nextop && nextop->op_type == OP_NULL)
9268 nextop = nextop->op_next;
9270 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9271 COP *firstcop = (COP *)o;
9272 COP *secondcop = (COP *)nextop;
9273 /* We want the COP pointed to by o (and anything else) to
9274 become the next COP down the line. */
9277 firstcop->op_next = secondcop->op_next;
9279 /* Now steal all its pointers, and duplicate the other
9281 firstcop->cop_line = secondcop->cop_line;
9283 firstcop->cop_stashpv = secondcop->cop_stashpv;
9284 firstcop->cop_file = secondcop->cop_file;
9286 firstcop->cop_stash = secondcop->cop_stash;
9287 firstcop->cop_filegv = secondcop->cop_filegv;
9289 firstcop->cop_hints = secondcop->cop_hints;
9290 firstcop->cop_seq = secondcop->cop_seq;
9291 firstcop->cop_warnings = secondcop->cop_warnings;
9292 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9295 secondcop->cop_stashpv = NULL;
9296 secondcop->cop_file = NULL;
9298 secondcop->cop_stash = NULL;
9299 secondcop->cop_filegv = NULL;
9301 secondcop->cop_warnings = NULL;
9302 secondcop->cop_hints_hash = NULL;
9304 /* If we use op_null(), and hence leave an ex-COP, some
9305 warnings are misreported. For example, the compile-time
9306 error in 'use strict; no strict refs;' */
9307 secondcop->op_type = OP_NULL;
9308 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9314 if (cSVOPo->op_private & OPpCONST_STRICT)
9315 no_bareword_allowed(o);
9318 case OP_METHOD_NAMED:
9319 /* Relocate sv to the pad for thread safety.
9320 * Despite being a "constant", the SV is written to,
9321 * for reference counts, sv_upgrade() etc. */
9323 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9324 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9325 /* If op_sv is already a PADTMP then it is being used by
9326 * some pad, so make a copy. */
9327 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9328 SvREADONLY_on(PAD_SVl(ix));
9329 SvREFCNT_dec(cSVOPo->op_sv);
9331 else if (o->op_type != OP_METHOD_NAMED
9332 && cSVOPo->op_sv == &PL_sv_undef) {
9333 /* PL_sv_undef is hack - it's unsafe to store it in the
9334 AV that is the pad, because av_fetch treats values of
9335 PL_sv_undef as a "free" AV entry and will merrily
9336 replace them with a new SV, causing pad_alloc to think
9337 that this pad slot is free. (When, clearly, it is not)
9339 SvOK_off(PAD_SVl(ix));
9340 SvPADTMP_on(PAD_SVl(ix));
9341 SvREADONLY_on(PAD_SVl(ix));
9344 SvREFCNT_dec(PAD_SVl(ix));
9345 SvPADTMP_on(cSVOPo->op_sv);
9346 PAD_SETSV(ix, cSVOPo->op_sv);
9347 /* XXX I don't know how this isn't readonly already. */
9348 SvREADONLY_on(PAD_SVl(ix));
9350 cSVOPo->op_sv = NULL;
9357 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9358 if (o->op_next->op_private & OPpTARGET_MY) {
9359 if (o->op_flags & OPf_STACKED) /* chained concats */
9360 break; /* ignore_optimization */
9362 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9363 o->op_targ = o->op_next->op_targ;
9364 o->op_next->op_targ = 0;
9365 o->op_private |= OPpTARGET_MY;
9368 op_null(o->op_next);
9372 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9373 break; /* Scalar stub must produce undef. List stub is noop */
9377 if (o->op_targ == OP_NEXTSTATE
9378 || o->op_targ == OP_DBSTATE)
9380 PL_curcop = ((COP*)o);
9382 /* XXX: We avoid setting op_seq here to prevent later calls
9383 to rpeep() from mistakenly concluding that optimisation
9384 has already occurred. This doesn't fix the real problem,
9385 though (See 20010220.007). AMS 20010719 */
9386 /* op_seq functionality is now replaced by op_opt */
9393 if (oldop && o->op_next) {
9394 oldop->op_next = o->op_next;
9402 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9403 OP* const pop = (o->op_type == OP_PADAV) ?
9404 o->op_next : o->op_next->op_next;
9406 if (pop && pop->op_type == OP_CONST &&
9407 ((PL_op = pop->op_next)) &&
9408 pop->op_next->op_type == OP_AELEM &&
9409 !(pop->op_next->op_private &
9410 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9411 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9416 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9417 no_bareword_allowed(pop);
9418 if (o->op_type == OP_GV)
9419 op_null(o->op_next);
9420 op_null(pop->op_next);
9422 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9423 o->op_next = pop->op_next->op_next;
9424 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9425 o->op_private = (U8)i;
9426 if (o->op_type == OP_GV) {
9431 o->op_flags |= OPf_SPECIAL;
9432 o->op_type = OP_AELEMFAST;
9437 if (o->op_next->op_type == OP_RV2SV) {
9438 if (!(o->op_next->op_private & OPpDEREF)) {
9439 op_null(o->op_next);
9440 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9442 o->op_next = o->op_next->op_next;
9443 o->op_type = OP_GVSV;
9444 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9447 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9448 GV * const gv = cGVOPo_gv;
9449 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9450 /* XXX could check prototype here instead of just carping */
9451 SV * const sv = sv_newmortal();
9452 gv_efullname3(sv, gv, NULL);
9453 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9454 "%"SVf"() called too early to check prototype",
9458 else if (o->op_next->op_type == OP_READLINE
9459 && o->op_next->op_next->op_type == OP_CONCAT
9460 && (o->op_next->op_next->op_flags & OPf_STACKED))
9462 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9463 o->op_type = OP_RCATLINE;
9464 o->op_flags |= OPf_STACKED;
9465 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9466 op_null(o->op_next->op_next);
9467 op_null(o->op_next);
9477 fop = cUNOP->op_first;
9485 fop = cLOGOP->op_first;
9486 sop = fop->op_sibling;
9487 while (cLOGOP->op_other->op_type == OP_NULL)
9488 cLOGOP->op_other = cLOGOP->op_other->op_next;
9489 CALL_RPEEP(cLOGOP->op_other);
9493 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9495 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9500 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9501 while (nop && nop->op_next) {
9502 switch (nop->op_next->op_type) {
9507 lop = nop = nop->op_next;
9518 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9519 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9520 cLOGOP->op_first = opt_scalarhv(fop);
9521 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9522 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9538 while (cLOGOP->op_other->op_type == OP_NULL)
9539 cLOGOP->op_other = cLOGOP->op_other->op_next;
9540 CALL_RPEEP(cLOGOP->op_other);
9545 while (cLOOP->op_redoop->op_type == OP_NULL)
9546 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9547 CALL_RPEEP(cLOOP->op_redoop);
9548 while (cLOOP->op_nextop->op_type == OP_NULL)
9549 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9550 CALL_RPEEP(cLOOP->op_nextop);
9551 while (cLOOP->op_lastop->op_type == OP_NULL)
9552 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9553 CALL_RPEEP(cLOOP->op_lastop);
9557 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9558 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9559 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9560 cPMOP->op_pmstashstartu.op_pmreplstart
9561 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9562 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9566 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9567 && ckWARN(WARN_SYNTAX))
9569 if (o->op_next->op_sibling) {
9570 const OPCODE type = o->op_next->op_sibling->op_type;
9571 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9572 const line_t oldline = CopLINE(PL_curcop);
9573 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9574 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9575 "Statement unlikely to be reached");
9576 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9577 "\t(Maybe you meant system() when you said exec()?)\n");
9578 CopLINE_set(PL_curcop, oldline);
9589 const char *key = NULL;
9592 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9595 /* Make the CONST have a shared SV */
9596 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9597 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9598 key = SvPV_const(sv, keylen);
9599 lexname = newSVpvn_share(key,
9600 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9606 if ((o->op_private & (OPpLVAL_INTRO)))
9609 rop = (UNOP*)((BINOP*)o)->op_first;
9610 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9612 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9613 if (!SvPAD_TYPED(lexname))
9615 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9616 if (!fields || !GvHV(*fields))
9618 key = SvPV_const(*svp, keylen);
9619 if (!hv_fetch(GvHV(*fields), key,
9620 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9622 Perl_croak(aTHX_ "No such class field \"%s\" "
9623 "in variable %s of type %s",
9624 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9637 SVOP *first_key_op, *key_op;
9639 if ((o->op_private & (OPpLVAL_INTRO))
9640 /* I bet there's always a pushmark... */
9641 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9642 /* hmmm, no optimization if list contains only one key. */
9644 rop = (UNOP*)((LISTOP*)o)->op_last;
9645 if (rop->op_type != OP_RV2HV)
9647 if (rop->op_first->op_type == OP_PADSV)
9648 /* @$hash{qw(keys here)} */
9649 rop = (UNOP*)rop->op_first;
9651 /* @{$hash}{qw(keys here)} */
9652 if (rop->op_first->op_type == OP_SCOPE
9653 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9655 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9661 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9662 if (!SvPAD_TYPED(lexname))
9664 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9665 if (!fields || !GvHV(*fields))
9667 /* Again guessing that the pushmark can be jumped over.... */
9668 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9669 ->op_first->op_sibling;
9670 for (key_op = first_key_op; key_op;
9671 key_op = (SVOP*)key_op->op_sibling) {
9672 if (key_op->op_type != OP_CONST)
9674 svp = cSVOPx_svp(key_op);
9675 key = SvPV_const(*svp, keylen);
9676 if (!hv_fetch(GvHV(*fields), key,
9677 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9679 Perl_croak(aTHX_ "No such class field \"%s\" "
9680 "in variable %s of type %s",
9681 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9690 && ( oldop->op_type == OP_AELEM
9691 || oldop->op_type == OP_PADSV
9692 || oldop->op_type == OP_RV2SV
9693 || oldop->op_type == OP_RV2GV
9694 || oldop->op_type == OP_HELEM
9696 && (oldop->op_private & OPpDEREF)
9698 o->op_private |= OPpDEREFed;
9702 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9706 /* check that RHS of sort is a single plain array */
9707 OP *oright = cUNOPo->op_first;
9708 if (!oright || oright->op_type != OP_PUSHMARK)
9711 /* reverse sort ... can be optimised. */
9712 if (!cUNOPo->op_sibling) {
9713 /* Nothing follows us on the list. */
9714 OP * const reverse = o->op_next;
9716 if (reverse->op_type == OP_REVERSE &&
9717 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9718 OP * const pushmark = cUNOPx(reverse)->op_first;
9719 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9720 && (cUNOPx(pushmark)->op_sibling == o)) {
9721 /* reverse -> pushmark -> sort */
9722 o->op_private |= OPpSORT_REVERSE;
9724 pushmark->op_next = oright->op_next;
9730 /* make @a = sort @a act in-place */
9732 oright = cUNOPx(oright)->op_sibling;
9735 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9736 oright = cUNOPx(oright)->op_sibling;
9739 oleft = is_inplace_av(o, oright);
9743 /* transfer MODishness etc from LHS arg to RHS arg */
9744 oright->op_flags = oleft->op_flags;
9745 o->op_private |= OPpSORT_INPLACE;
9747 /* excise push->gv->rv2av->null->aassign */
9748 o2 = o->op_next->op_next;
9749 op_null(o2); /* PUSHMARK */
9751 if (o2->op_type == OP_GV) {
9752 op_null(o2); /* GV */
9755 op_null(o2); /* RV2AV or PADAV */
9756 o2 = o2->op_next->op_next;
9757 op_null(o2); /* AASSIGN */
9759 o->op_next = o2->op_next;
9765 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9768 LISTOP *enter, *exlist;
9770 /* @a = reverse @a */
9771 if ((oright = cLISTOPo->op_first)
9772 && (oright->op_type == OP_PUSHMARK)
9773 && (oright = oright->op_sibling)
9774 && (oleft = is_inplace_av(o, oright))) {
9777 /* transfer MODishness etc from LHS arg to RHS arg */
9778 oright->op_flags = oleft->op_flags;
9779 o->op_private |= OPpREVERSE_INPLACE;
9781 /* excise push->gv->rv2av->null->aassign */
9782 o2 = o->op_next->op_next;
9783 op_null(o2); /* PUSHMARK */
9785 if (o2->op_type == OP_GV) {
9786 op_null(o2); /* GV */
9789 op_null(o2); /* RV2AV or PADAV */
9790 o2 = o2->op_next->op_next;
9791 op_null(o2); /* AASSIGN */
9793 o->op_next = o2->op_next;
9797 enter = (LISTOP *) o->op_next;
9800 if (enter->op_type == OP_NULL) {
9801 enter = (LISTOP *) enter->op_next;
9805 /* for $a (...) will have OP_GV then OP_RV2GV here.
9806 for (...) just has an OP_GV. */
9807 if (enter->op_type == OP_GV) {
9808 gvop = (OP *) enter;
9809 enter = (LISTOP *) enter->op_next;
9812 if (enter->op_type == OP_RV2GV) {
9813 enter = (LISTOP *) enter->op_next;
9819 if (enter->op_type != OP_ENTERITER)
9822 iter = enter->op_next;
9823 if (!iter || iter->op_type != OP_ITER)
9826 expushmark = enter->op_first;
9827 if (!expushmark || expushmark->op_type != OP_NULL
9828 || expushmark->op_targ != OP_PUSHMARK)
9831 exlist = (LISTOP *) expushmark->op_sibling;
9832 if (!exlist || exlist->op_type != OP_NULL
9833 || exlist->op_targ != OP_LIST)
9836 if (exlist->op_last != o) {
9837 /* Mmm. Was expecting to point back to this op. */
9840 theirmark = exlist->op_first;
9841 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9844 if (theirmark->op_sibling != o) {
9845 /* There's something between the mark and the reverse, eg
9846 for (1, reverse (...))
9851 ourmark = ((LISTOP *)o)->op_first;
9852 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9855 ourlast = ((LISTOP *)o)->op_last;
9856 if (!ourlast || ourlast->op_next != o)
9859 rv2av = ourmark->op_sibling;
9860 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9861 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9862 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9863 /* We're just reversing a single array. */
9864 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9865 enter->op_flags |= OPf_STACKED;
9868 /* We don't have control over who points to theirmark, so sacrifice
9870 theirmark->op_next = ourmark->op_next;
9871 theirmark->op_flags = ourmark->op_flags;
9872 ourlast->op_next = gvop ? gvop : (OP *) enter;
9875 enter->op_private |= OPpITER_REVERSED;
9876 iter->op_private |= OPpITER_REVERSED;
9883 UNOP *refgen, *rv2cv;
9886 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9889 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9892 rv2gv = ((BINOP *)o)->op_last;
9893 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9896 refgen = (UNOP *)((BINOP *)o)->op_first;
9898 if (!refgen || refgen->op_type != OP_REFGEN)
9901 exlist = (LISTOP *)refgen->op_first;
9902 if (!exlist || exlist->op_type != OP_NULL
9903 || exlist->op_targ != OP_LIST)
9906 if (exlist->op_first->op_type != OP_PUSHMARK)
9909 rv2cv = (UNOP*)exlist->op_last;
9911 if (rv2cv->op_type != OP_RV2CV)
9914 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9915 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9916 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9918 o->op_private |= OPpASSIGN_CV_TO_GV;
9919 rv2gv->op_private |= OPpDONT_INIT_GV;
9920 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9928 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9929 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9939 Perl_peep(pTHX_ register OP *o)
9945 Perl_custom_op_name(pTHX_ const OP* o)
9948 const IV index = PTR2IV(o->op_ppaddr);
9952 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9954 if (!PL_custom_op_names) /* This probably shouldn't happen */
9955 return (char *)PL_op_name[OP_CUSTOM];
9957 keysv = sv_2mortal(newSViv(index));
9959 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9961 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9963 return SvPV_nolen(HeVAL(he));
9967 Perl_custom_op_desc(pTHX_ const OP* o)
9970 const IV index = PTR2IV(o->op_ppaddr);
9974 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9976 if (!PL_custom_op_descs)
9977 return (char *)PL_op_desc[OP_CUSTOM];
9979 keysv = sv_2mortal(newSViv(index));
9981 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9983 return (char *)PL_op_desc[OP_CUSTOM];
9985 return SvPV_nolen(HeVAL(he));
9990 /* Efficient sub that returns a constant scalar value. */
9992 const_sv_xsub(pTHX_ CV* cv)
9996 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10000 /* diag_listed_as: SKIPME */
10001 Perl_croak(aTHX_ "usage: %s::%s()",
10002 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10015 * c-indentation-style: bsd
10016 * c-basic-offset: 4
10017 * indent-tabs-mode: t
10020 * ex: set ts=8 sts=4 sw=4 noet: