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] != MEMBER_TO_FPTR(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 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
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 */
821 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
824 S_linklist(pTHX_ OP *o)
828 PERL_ARGS_ASSERT_LINKLIST;
833 /* establish postfix order */
834 first = cUNOPo->op_first;
837 o->op_next = LINKLIST(first);
840 if (kid->op_sibling) {
841 kid->op_next = LINKLIST(kid->op_sibling);
842 kid = kid->op_sibling;
856 S_scalarkids(pTHX_ OP *o)
858 if (o && o->op_flags & OPf_KIDS) {
860 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
867 S_scalarboolean(pTHX_ OP *o)
871 PERL_ARGS_ASSERT_SCALARBOOLEAN;
873 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
874 if (ckWARN(WARN_SYNTAX)) {
875 const line_t oldline = CopLINE(PL_curcop);
877 if (PL_parser && PL_parser->copline != NOLINE)
878 CopLINE_set(PL_curcop, PL_parser->copline);
879 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
880 CopLINE_set(PL_curcop, oldline);
887 Perl_scalar(pTHX_ OP *o)
892 /* assumes no premature commitment */
893 if (!o || (PL_parser && PL_parser->error_count)
894 || (o->op_flags & OPf_WANT)
895 || o->op_type == OP_RETURN)
900 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
902 switch (o->op_type) {
904 scalar(cBINOPo->op_first);
909 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
919 if (o->op_flags & OPf_KIDS) {
920 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
926 kid = cLISTOPo->op_first;
928 kid = kid->op_sibling;
931 OP *sib = kid->op_sibling;
932 if (sib && kid->op_type != OP_LEAVEWHEN) {
933 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
943 PL_curcop = &PL_compiling;
948 kid = cLISTOPo->op_first;
951 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
958 Perl_scalarvoid(pTHX_ OP *o)
962 const char* useless = NULL;
966 PERL_ARGS_ASSERT_SCALARVOID;
968 /* trailing mad null ops don't count as "there" for void processing */
970 o->op_type != OP_NULL &&
972 o->op_sibling->op_type == OP_NULL)
975 for (sib = o->op_sibling;
976 sib && sib->op_type == OP_NULL;
977 sib = sib->op_sibling) ;
983 if (o->op_type == OP_NEXTSTATE
984 || o->op_type == OP_DBSTATE
985 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
986 || o->op_targ == OP_DBSTATE)))
987 PL_curcop = (COP*)o; /* for warning below */
989 /* assumes no premature commitment */
990 want = o->op_flags & OPf_WANT;
991 if ((want && want != OPf_WANT_SCALAR)
992 || (PL_parser && PL_parser->error_count)
993 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
998 if ((o->op_private & OPpTARGET_MY)
999 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1001 return scalar(o); /* As if inside SASSIGN */
1004 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1006 switch (o->op_type) {
1008 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1012 if (o->op_flags & OPf_STACKED)
1016 if (o->op_private == 4)
1059 case OP_GETSOCKNAME:
1060 case OP_GETPEERNAME:
1065 case OP_GETPRIORITY:
1089 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1090 /* Otherwise it's "Useless use of grep iterator" */
1091 useless = OP_DESC(o);
1095 kid = cLISTOPo->op_first;
1096 if (kid && kid->op_type == OP_PUSHRE
1098 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1100 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1102 useless = OP_DESC(o);
1106 kid = cUNOPo->op_first;
1107 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1108 kid->op_type != OP_TRANS) {
1111 useless = "negative pattern binding (!~)";
1115 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1116 useless = "Non-destructive substitution (s///r)";
1123 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1124 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1125 useless = "a variable";
1130 if (cSVOPo->op_private & OPpCONST_STRICT)
1131 no_bareword_allowed(o);
1133 if (ckWARN(WARN_VOID)) {
1135 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1136 "a constant (%"SVf")", sv));
1137 useless = SvPV_nolen(msv);
1140 useless = "a constant (undef)";
1141 if (o->op_private & OPpCONST_ARYBASE)
1143 /* don't warn on optimised away booleans, eg
1144 * use constant Foo, 5; Foo || print; */
1145 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1147 /* the constants 0 and 1 are permitted as they are
1148 conventionally used as dummies in constructs like
1149 1 while some_condition_with_side_effects; */
1150 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1152 else if (SvPOK(sv)) {
1153 /* perl4's way of mixing documentation and code
1154 (before the invention of POD) was based on a
1155 trick to mix nroff and perl code. The trick was
1156 built upon these three nroff macros being used in
1157 void context. The pink camel has the details in
1158 the script wrapman near page 319. */
1159 const char * const maybe_macro = SvPVX_const(sv);
1160 if (strnEQ(maybe_macro, "di", 2) ||
1161 strnEQ(maybe_macro, "ds", 2) ||
1162 strnEQ(maybe_macro, "ig", 2))
1167 op_null(o); /* don't execute or even remember it */
1171 o->op_type = OP_PREINC; /* pre-increment is faster */
1172 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1176 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1177 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1181 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1182 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1186 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1187 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1192 kid = cLOGOPo->op_first;
1193 if (kid->op_type == OP_NOT
1194 && (kid->op_flags & OPf_KIDS)
1196 if (o->op_type == OP_AND) {
1198 o->op_ppaddr = PL_ppaddr[OP_OR];
1200 o->op_type = OP_AND;
1201 o->op_ppaddr = PL_ppaddr[OP_AND];
1210 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1215 if (o->op_flags & OPf_STACKED)
1222 if (!(o->op_flags & OPf_KIDS))
1233 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1243 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1248 S_listkids(pTHX_ OP *o)
1250 if (o && o->op_flags & OPf_KIDS) {
1252 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1259 Perl_list(pTHX_ OP *o)
1264 /* assumes no premature commitment */
1265 if (!o || (o->op_flags & OPf_WANT)
1266 || (PL_parser && PL_parser->error_count)
1267 || o->op_type == OP_RETURN)
1272 if ((o->op_private & OPpTARGET_MY)
1273 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1275 return o; /* As if inside SASSIGN */
1278 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1280 switch (o->op_type) {
1283 list(cBINOPo->op_first);
1288 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1296 if (!(o->op_flags & OPf_KIDS))
1298 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1299 list(cBINOPo->op_first);
1300 return gen_constant_list(o);
1307 kid = cLISTOPo->op_first;
1309 kid = kid->op_sibling;
1312 OP *sib = kid->op_sibling;
1313 if (sib && kid->op_type != OP_LEAVEWHEN) {
1314 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1324 PL_curcop = &PL_compiling;
1328 kid = cLISTOPo->op_first;
1335 S_scalarseq(pTHX_ OP *o)
1339 const OPCODE type = o->op_type;
1341 if (type == OP_LINESEQ || type == OP_SCOPE ||
1342 type == OP_LEAVE || type == OP_LEAVETRY)
1345 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1346 if (kid->op_sibling) {
1350 PL_curcop = &PL_compiling;
1352 o->op_flags &= ~OPf_PARENS;
1353 if (PL_hints & HINT_BLOCK_SCOPE)
1354 o->op_flags |= OPf_PARENS;
1357 o = newOP(OP_STUB, 0);
1362 S_modkids(pTHX_ OP *o, I32 type)
1364 if (o && o->op_flags & OPf_KIDS) {
1366 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1372 /* Propagate lvalue ("modifiable") context to an op and its children.
1373 * 'type' represents the context type, roughly based on the type of op that
1374 * would do the modifying, although local() is represented by OP_NULL.
1375 * It's responsible for detecting things that can't be modified, flag
1376 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1377 * might have to vivify a reference in $x), and so on.
1379 * For example, "$a+1 = 2" would cause mod() to be called with o being
1380 * OP_ADD and type being OP_SASSIGN, and would output an error.
1384 Perl_mod(pTHX_ OP *o, I32 type)
1388 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1391 if (!o || (PL_parser && PL_parser->error_count))
1394 if ((o->op_private & OPpTARGET_MY)
1395 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1400 switch (o->op_type) {
1406 if (!(o->op_private & OPpCONST_ARYBASE))
1409 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1410 CopARYBASE_set(&PL_compiling,
1411 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1415 SAVECOPARYBASE(&PL_compiling);
1416 CopARYBASE_set(&PL_compiling, 0);
1418 else if (type == OP_REFGEN)
1421 Perl_croak(aTHX_ "That use of $[ is unsupported");
1424 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1428 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1429 !(o->op_flags & OPf_STACKED)) {
1430 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1431 /* The default is to set op_private to the number of children,
1432 which for a UNOP such as RV2CV is always 1. And w're using
1433 the bit for a flag in RV2CV, so we need it clear. */
1434 o->op_private &= ~1;
1435 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436 assert(cUNOPo->op_first->op_type == OP_NULL);
1437 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1440 else if (o->op_private & OPpENTERSUB_NOMOD)
1442 else { /* lvalue subroutine call */
1443 o->op_private |= OPpLVAL_INTRO;
1444 PL_modcount = RETURN_UNLIMITED_NUMBER;
1445 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1446 /* Backward compatibility mode: */
1447 o->op_private |= OPpENTERSUB_INARGS;
1450 else { /* Compile-time error message: */
1451 OP *kid = cUNOPo->op_first;
1455 if (kid->op_type != OP_PUSHMARK) {
1456 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1458 "panic: unexpected lvalue entersub "
1459 "args: type/targ %ld:%"UVuf,
1460 (long)kid->op_type, (UV)kid->op_targ);
1461 kid = kLISTOP->op_first;
1463 while (kid->op_sibling)
1464 kid = kid->op_sibling;
1465 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1467 if (kid->op_type == OP_METHOD_NAMED
1468 || kid->op_type == OP_METHOD)
1472 NewOp(1101, newop, 1, UNOP);
1473 newop->op_type = OP_RV2CV;
1474 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1475 newop->op_first = NULL;
1476 newop->op_next = (OP*)newop;
1477 kid->op_sibling = (OP*)newop;
1478 newop->op_private |= OPpLVAL_INTRO;
1479 newop->op_private &= ~1;
1483 if (kid->op_type != OP_RV2CV)
1485 "panic: unexpected lvalue entersub "
1486 "entry via type/targ %ld:%"UVuf,
1487 (long)kid->op_type, (UV)kid->op_targ);
1488 kid->op_private |= OPpLVAL_INTRO;
1489 break; /* Postpone until runtime */
1493 kid = kUNOP->op_first;
1494 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1495 kid = kUNOP->op_first;
1496 if (kid->op_type == OP_NULL)
1498 "Unexpected constant lvalue entersub "
1499 "entry via type/targ %ld:%"UVuf,
1500 (long)kid->op_type, (UV)kid->op_targ);
1501 if (kid->op_type != OP_GV) {
1502 /* Restore RV2CV to check lvalueness */
1504 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1505 okid->op_next = kid->op_next;
1506 kid->op_next = okid;
1509 okid->op_next = NULL;
1510 okid->op_type = OP_RV2CV;
1512 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1513 okid->op_private |= OPpLVAL_INTRO;
1514 okid->op_private &= ~1;
1518 cv = GvCV(kGVOP_gv);
1528 /* grep, foreach, subcalls, refgen */
1529 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1531 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1532 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1534 : (o->op_type == OP_ENTERSUB
1535 ? "non-lvalue subroutine call"
1537 type ? PL_op_desc[type] : "local"));
1551 case OP_RIGHT_SHIFT:
1560 if (!(o->op_flags & OPf_STACKED))
1567 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1573 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1574 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 return o; /* Treat \(@foo) like ordinary list. */
1579 if (scalar_mod_type(o, type))
1581 ref(cUNOPo->op_first, o->op_type);
1585 if (type == OP_LEAVESUBLV)
1586 o->op_private |= OPpMAYBE_LVSUB;
1592 PL_modcount = RETURN_UNLIMITED_NUMBER;
1595 PL_hints |= HINT_BLOCK_SCOPE;
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1601 ref(cUNOPo->op_first, o->op_type);
1605 PL_hints |= HINT_BLOCK_SCOPE;
1620 PL_modcount = RETURN_UNLIMITED_NUMBER;
1621 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1622 return o; /* Treat \(@foo) like ordinary list. */
1623 if (scalar_mod_type(o, type))
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1630 if (!type) /* local() */
1631 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1632 PAD_COMPNAME_PV(o->op_targ));
1640 if (type != OP_SASSIGN)
1644 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1649 if (type == OP_LEAVESUBLV)
1650 o->op_private |= OPpMAYBE_LVSUB;
1652 pad_free(o->op_targ);
1653 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1654 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1655 if (o->op_flags & OPf_KIDS)
1656 mod(cBINOPo->op_first->op_sibling, type);
1661 ref(cBINOPo->op_first, o->op_type);
1662 if (type == OP_ENTERSUB &&
1663 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1664 o->op_private |= OPpLVAL_DEFER;
1665 if (type == OP_LEAVESUBLV)
1666 o->op_private |= OPpMAYBE_LVSUB;
1676 if (o->op_flags & OPf_KIDS)
1677 mod(cLISTOPo->op_last, type);
1682 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1684 else if (!(o->op_flags & OPf_KIDS))
1686 if (o->op_targ != OP_LIST) {
1687 mod(cBINOPo->op_first, type);
1693 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1698 if (type != OP_LEAVESUBLV)
1700 break; /* mod()ing was handled by ck_return() */
1703 /* [20011101.069] File test operators interpret OPf_REF to mean that
1704 their argument is a filehandle; thus \stat(".") should not set
1706 if (type == OP_REFGEN &&
1707 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1710 if (type != OP_LEAVESUBLV)
1711 o->op_flags |= OPf_MOD;
1713 if (type == OP_AASSIGN || type == OP_SASSIGN)
1714 o->op_flags |= OPf_SPECIAL|OPf_REF;
1715 else if (!type) { /* local() */
1718 o->op_private |= OPpLVAL_INTRO;
1719 o->op_flags &= ~OPf_SPECIAL;
1720 PL_hints |= HINT_BLOCK_SCOPE;
1725 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1726 "Useless localization of %s", OP_DESC(o));
1729 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1730 && type != OP_LEAVESUBLV)
1731 o->op_flags |= OPf_REF;
1736 S_scalar_mod_type(const OP *o, I32 type)
1738 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1742 if (o->op_type == OP_RV2GV)
1766 case OP_RIGHT_SHIFT:
1786 S_is_handle_constructor(const OP *o, I32 numargs)
1788 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1790 switch (o->op_type) {
1798 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1811 S_refkids(pTHX_ OP *o, I32 type)
1813 if (o && o->op_flags & OPf_KIDS) {
1815 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1822 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1827 PERL_ARGS_ASSERT_DOREF;
1829 if (!o || (PL_parser && PL_parser->error_count))
1832 switch (o->op_type) {
1834 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1835 !(o->op_flags & OPf_STACKED)) {
1836 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1837 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1838 assert(cUNOPo->op_first->op_type == OP_NULL);
1839 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1840 o->op_flags |= OPf_SPECIAL;
1841 o->op_private &= ~1;
1846 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1847 doref(kid, type, set_op_ref);
1850 if (type == OP_DEFINED)
1851 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1852 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1855 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1856 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1857 : type == OP_RV2HV ? OPpDEREF_HV
1859 o->op_flags |= OPf_MOD;
1866 o->op_flags |= OPf_REF;
1869 if (type == OP_DEFINED)
1870 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1871 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1877 o->op_flags |= OPf_REF;
1882 if (!(o->op_flags & OPf_KIDS))
1884 doref(cBINOPo->op_first, type, set_op_ref);
1888 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1889 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1890 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1891 : type == OP_RV2HV ? OPpDEREF_HV
1893 o->op_flags |= OPf_MOD;
1903 if (!(o->op_flags & OPf_KIDS))
1905 doref(cLISTOPo->op_last, type, set_op_ref);
1915 S_dup_attrlist(pTHX_ OP *o)
1920 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1922 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1923 * where the first kid is OP_PUSHMARK and the remaining ones
1924 * are OP_CONST. We need to push the OP_CONST values.
1926 if (o->op_type == OP_CONST)
1927 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1929 else if (o->op_type == OP_NULL)
1933 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1935 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1936 if (o->op_type == OP_CONST)
1937 rop = append_elem(OP_LIST, rop,
1938 newSVOP(OP_CONST, o->op_flags,
1939 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1946 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1951 PERL_ARGS_ASSERT_APPLY_ATTRS;
1953 /* fake up C<use attributes $pkg,$rv,@attrs> */
1954 ENTER; /* need to protect against side-effects of 'use' */
1955 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1957 #define ATTRSMODULE "attributes"
1958 #define ATTRSMODULE_PM "attributes.pm"
1961 /* Don't force the C<use> if we don't need it. */
1962 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1963 if (svp && *svp != &PL_sv_undef)
1964 NOOP; /* already in %INC */
1966 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1967 newSVpvs(ATTRSMODULE), NULL);
1970 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1971 newSVpvs(ATTRSMODULE),
1973 prepend_elem(OP_LIST,
1974 newSVOP(OP_CONST, 0, stashsv),
1975 prepend_elem(OP_LIST,
1976 newSVOP(OP_CONST, 0,
1978 dup_attrlist(attrs))));
1984 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1987 OP *pack, *imop, *arg;
1990 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1995 assert(target->op_type == OP_PADSV ||
1996 target->op_type == OP_PADHV ||
1997 target->op_type == OP_PADAV);
1999 /* Ensure that attributes.pm is loaded. */
2000 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2002 /* Need package name for method call. */
2003 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2005 /* Build up the real arg-list. */
2006 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2008 arg = newOP(OP_PADSV, 0);
2009 arg->op_targ = target->op_targ;
2010 arg = prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, stashsv),
2012 prepend_elem(OP_LIST,
2013 newUNOP(OP_REFGEN, 0,
2014 mod(arg, OP_REFGEN)),
2015 dup_attrlist(attrs)));
2017 /* Fake up a method call to import */
2018 meth = newSVpvs_share("import");
2019 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2020 append_elem(OP_LIST,
2021 prepend_elem(OP_LIST, pack, list(arg)),
2022 newSVOP(OP_METHOD_NAMED, 0, meth)));
2023 imop->op_private |= OPpENTERSUB_NOMOD;
2025 /* Combine the ops. */
2026 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2030 =notfor apidoc apply_attrs_string
2032 Attempts to apply a list of attributes specified by the C<attrstr> and
2033 C<len> arguments to the subroutine identified by the C<cv> argument which
2034 is expected to be associated with the package identified by the C<stashpv>
2035 argument (see L<attributes>). It gets this wrong, though, in that it
2036 does not correctly identify the boundaries of the individual attribute
2037 specifications within C<attrstr>. This is not really intended for the
2038 public API, but has to be listed here for systems such as AIX which
2039 need an explicit export list for symbols. (It's called from XS code
2040 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2041 to respect attribute syntax properly would be welcome.
2047 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2048 const char *attrstr, STRLEN len)
2052 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2055 len = strlen(attrstr);
2059 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2061 const char * const sstr = attrstr;
2062 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2063 attrs = append_elem(OP_LIST, attrs,
2064 newSVOP(OP_CONST, 0,
2065 newSVpvn(sstr, attrstr-sstr)));
2069 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2070 newSVpvs(ATTRSMODULE),
2071 NULL, prepend_elem(OP_LIST,
2072 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2073 prepend_elem(OP_LIST,
2074 newSVOP(OP_CONST, 0,
2075 newRV(MUTABLE_SV(cv))),
2080 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2085 PERL_ARGS_ASSERT_MY_KID;
2087 if (!o || (PL_parser && PL_parser->error_count))
2091 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2092 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2096 if (type == OP_LIST) {
2098 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2099 my_kid(kid, attrs, imopsp);
2100 } else if (type == OP_UNDEF
2106 } else if (type == OP_RV2SV || /* "our" declaration */
2108 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2109 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2110 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2112 PL_parser->in_my == KEY_our
2114 : PL_parser->in_my == KEY_state ? "state" : "my"));
2116 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2117 PL_parser->in_my = FALSE;
2118 PL_parser->in_my_stash = NULL;
2119 apply_attrs(GvSTASH(gv),
2120 (type == OP_RV2SV ? GvSV(gv) :
2121 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2122 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2125 o->op_private |= OPpOUR_INTRO;
2128 else if (type != OP_PADSV &&
2131 type != OP_PUSHMARK)
2133 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2135 PL_parser->in_my == KEY_our
2137 : PL_parser->in_my == KEY_state ? "state" : "my"));
2140 else if (attrs && type != OP_PUSHMARK) {
2143 PL_parser->in_my = FALSE;
2144 PL_parser->in_my_stash = NULL;
2146 /* check for C<my Dog $spot> when deciding package */
2147 stash = PAD_COMPNAME_TYPE(o->op_targ);
2149 stash = PL_curstash;
2150 apply_attrs_my(stash, o, attrs, imopsp);
2152 o->op_flags |= OPf_MOD;
2153 o->op_private |= OPpLVAL_INTRO;
2154 if (PL_parser->in_my == KEY_state)
2155 o->op_private |= OPpPAD_STATE;
2160 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2164 int maybe_scalar = 0;
2166 PERL_ARGS_ASSERT_MY_ATTRS;
2168 /* [perl #17376]: this appears to be premature, and results in code such as
2169 C< our(%x); > executing in list mode rather than void mode */
2171 if (o->op_flags & OPf_PARENS)
2181 o = my_kid(o, attrs, &rops);
2183 if (maybe_scalar && o->op_type == OP_PADSV) {
2184 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2185 o->op_private |= OPpLVAL_INTRO;
2188 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2190 PL_parser->in_my = FALSE;
2191 PL_parser->in_my_stash = NULL;
2196 Perl_sawparens(pTHX_ OP *o)
2198 PERL_UNUSED_CONTEXT;
2200 o->op_flags |= OPf_PARENS;
2205 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2209 const OPCODE ltype = left->op_type;
2210 const OPCODE rtype = right->op_type;
2212 PERL_ARGS_ASSERT_BIND_MATCH;
2214 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2215 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2217 const char * const desc
2218 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2219 ? (int)rtype : OP_MATCH];
2220 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2221 ? "@array" : "%hash");
2222 Perl_warner(aTHX_ packWARN(WARN_MISC),
2223 "Applying %s to %s will act on scalar(%s)",
2224 desc, sample, sample);
2227 if (rtype == OP_CONST &&
2228 cSVOPx(right)->op_private & OPpCONST_BARE &&
2229 cSVOPx(right)->op_private & OPpCONST_STRICT)
2231 no_bareword_allowed(right);
2234 /* !~ doesn't make sense with s///r, so error on it for now */
2235 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2237 yyerror("Using !~ with s///r doesn't make sense");
2239 ismatchop = (rtype == OP_MATCH ||
2240 rtype == OP_SUBST ||
2242 && !(right->op_flags & OPf_SPECIAL);
2243 if (ismatchop && right->op_private & OPpTARGET_MY) {
2245 right->op_private &= ~OPpTARGET_MY;
2247 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2250 right->op_flags |= OPf_STACKED;
2251 if (rtype != OP_MATCH &&
2252 ! (rtype == OP_TRANS &&
2253 right->op_private & OPpTRANS_IDENTICAL) &&
2254 ! (rtype == OP_SUBST &&
2255 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2256 newleft = mod(left, rtype);
2259 if (right->op_type == OP_TRANS)
2260 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2262 o = prepend_elem(rtype, scalar(newleft), right);
2264 return newUNOP(OP_NOT, 0, scalar(o));
2268 return bind_match(type, left,
2269 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2273 Perl_invert(pTHX_ OP *o)
2277 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2281 Perl_scope(pTHX_ OP *o)
2285 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2286 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2287 o->op_type = OP_LEAVE;
2288 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2290 else if (o->op_type == OP_LINESEQ) {
2292 o->op_type = OP_SCOPE;
2293 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2294 kid = ((LISTOP*)o)->op_first;
2295 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2298 /* The following deals with things like 'do {1 for 1}' */
2299 kid = kid->op_sibling;
2301 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2306 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2312 Perl_block_start(pTHX_ int full)
2315 const int retval = PL_savestack_ix;
2317 pad_block_start(full);
2319 PL_hints &= ~HINT_BLOCK_SCOPE;
2320 SAVECOMPILEWARNINGS();
2321 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2323 CALL_BLOCK_HOOKS(start, full);
2329 Perl_block_end(pTHX_ I32 floor, OP *seq)
2332 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2333 OP* retval = scalarseq(seq);
2335 CALL_BLOCK_HOOKS(pre_end, &retval);
2338 CopHINTS_set(&PL_compiling, PL_hints);
2340 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2343 CALL_BLOCK_HOOKS(post_end, &retval);
2349 =head1 Compile-time scope hooks
2351 =for apidoc Ao||blockhook_register
2353 Register a set of hooks to be called when the Perl lexical scope changes
2354 at compile time. See L<perlguts/"Compile-time scope hooks">.
2360 Perl_blockhook_register(pTHX_ BHK *hk)
2362 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2364 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2371 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2372 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2373 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2376 OP * const o = newOP(OP_PADSV, 0);
2377 o->op_targ = offset;
2383 Perl_newPROG(pTHX_ OP *o)
2387 PERL_ARGS_ASSERT_NEWPROG;
2392 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2393 ((PL_in_eval & EVAL_KEEPERR)
2394 ? OPf_SPECIAL : 0), o);
2395 PL_eval_start = linklist(PL_eval_root);
2396 PL_eval_root->op_private |= OPpREFCOUNTED;
2397 OpREFCNT_set(PL_eval_root, 1);
2398 PL_eval_root->op_next = 0;
2399 CALL_PEEP(PL_eval_start);
2402 if (o->op_type == OP_STUB) {
2403 PL_comppad_name = 0;
2405 S_op_destroy(aTHX_ o);
2408 PL_main_root = scope(sawparens(scalarvoid(o)));
2409 PL_curcop = &PL_compiling;
2410 PL_main_start = LINKLIST(PL_main_root);
2411 PL_main_root->op_private |= OPpREFCOUNTED;
2412 OpREFCNT_set(PL_main_root, 1);
2413 PL_main_root->op_next = 0;
2414 CALL_PEEP(PL_main_start);
2417 /* Register with debugger */
2419 CV * const cv = get_cvs("DB::postponed", 0);
2423 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2425 call_sv(MUTABLE_SV(cv), G_DISCARD);
2432 Perl_localize(pTHX_ OP *o, I32 lex)
2436 PERL_ARGS_ASSERT_LOCALIZE;
2438 if (o->op_flags & OPf_PARENS)
2439 /* [perl #17376]: this appears to be premature, and results in code such as
2440 C< our(%x); > executing in list mode rather than void mode */
2447 if ( PL_parser->bufptr > PL_parser->oldbufptr
2448 && PL_parser->bufptr[-1] == ','
2449 && ckWARN(WARN_PARENTHESIS))
2451 char *s = PL_parser->bufptr;
2454 /* some heuristics to detect a potential error */
2455 while (*s && (strchr(", \t\n", *s)))
2459 if (*s && strchr("@$%*", *s) && *++s
2460 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2463 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2465 while (*s && (strchr(", \t\n", *s)))
2471 if (sigil && (*s == ';' || *s == '=')) {
2472 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2473 "Parentheses missing around \"%s\" list",
2475 ? (PL_parser->in_my == KEY_our
2477 : PL_parser->in_my == KEY_state
2487 o = mod(o, OP_NULL); /* a bit kludgey */
2488 PL_parser->in_my = FALSE;
2489 PL_parser->in_my_stash = NULL;
2494 Perl_jmaybe(pTHX_ OP *o)
2496 PERL_ARGS_ASSERT_JMAYBE;
2498 if (o->op_type == OP_LIST) {
2500 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2501 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2507 S_fold_constants(pTHX_ register OP *o)
2510 register OP * VOL curop;
2512 VOL I32 type = o->op_type;
2517 SV * const oldwarnhook = PL_warnhook;
2518 SV * const olddiehook = PL_diehook;
2522 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2524 if (PL_opargs[type] & OA_RETSCALAR)
2526 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2527 o->op_targ = pad_alloc(type, SVs_PADTMP);
2529 /* integerize op, unless it happens to be C<-foo>.
2530 * XXX should pp_i_negate() do magic string negation instead? */
2531 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2532 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2533 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2535 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2538 if (!(PL_opargs[type] & OA_FOLDCONST))
2543 /* XXX might want a ck_negate() for this */
2544 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2555 /* XXX what about the numeric ops? */
2556 if (PL_hints & HINT_LOCALE)
2561 if (PL_parser && PL_parser->error_count)
2562 goto nope; /* Don't try to run w/ errors */
2564 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2565 const OPCODE type = curop->op_type;
2566 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2568 type != OP_SCALAR &&
2570 type != OP_PUSHMARK)
2576 curop = LINKLIST(o);
2577 old_next = o->op_next;
2581 oldscope = PL_scopestack_ix;
2582 create_eval_scope(G_FAKINGEVAL);
2584 /* Verify that we don't need to save it: */
2585 assert(PL_curcop == &PL_compiling);
2586 StructCopy(&PL_compiling, ¬_compiling, COP);
2587 PL_curcop = ¬_compiling;
2588 /* The above ensures that we run with all the correct hints of the
2589 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2590 assert(IN_PERL_RUNTIME);
2591 PL_warnhook = PERL_WARNHOOK_FATAL;
2598 sv = *(PL_stack_sp--);
2599 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2600 pad_swipe(o->op_targ, FALSE);
2601 else if (SvTEMP(sv)) { /* grab mortal temp? */
2602 SvREFCNT_inc_simple_void(sv);
2607 /* Something tried to die. Abandon constant folding. */
2608 /* Pretend the error never happened. */
2610 o->op_next = old_next;
2614 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2615 PL_warnhook = oldwarnhook;
2616 PL_diehook = olddiehook;
2617 /* XXX note that this croak may fail as we've already blown away
2618 * the stack - eg any nested evals */
2619 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2622 PL_warnhook = oldwarnhook;
2623 PL_diehook = olddiehook;
2624 PL_curcop = &PL_compiling;
2626 if (PL_scopestack_ix > oldscope)
2627 delete_eval_scope();
2636 if (type == OP_RV2GV)
2637 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2639 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2640 op_getmad(o,newop,'f');
2648 S_gen_constant_list(pTHX_ register OP *o)
2652 const I32 oldtmps_floor = PL_tmps_floor;
2655 if (PL_parser && PL_parser->error_count)
2656 return o; /* Don't attempt to run with errors */
2658 PL_op = curop = LINKLIST(o);
2664 assert (!(curop->op_flags & OPf_SPECIAL));
2665 assert(curop->op_type == OP_RANGE);
2667 PL_tmps_floor = oldtmps_floor;
2669 o->op_type = OP_RV2AV;
2670 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2671 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2672 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2673 o->op_opt = 0; /* needs to be revisited in rpeep() */
2674 curop = ((UNOP*)o)->op_first;
2675 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2677 op_getmad(curop,o,'O');
2686 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2689 if (!o || o->op_type != OP_LIST)
2690 o = newLISTOP(OP_LIST, 0, o, NULL);
2692 o->op_flags &= ~OPf_WANT;
2694 if (!(PL_opargs[type] & OA_MARK))
2695 op_null(cLISTOPo->op_first);
2697 o->op_type = (OPCODE)type;
2698 o->op_ppaddr = PL_ppaddr[type];
2699 o->op_flags |= flags;
2701 o = CHECKOP(type, o);
2702 if (o->op_type != (unsigned)type)
2705 return fold_constants(o);
2708 /* List constructors */
2711 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2719 if (first->op_type != (unsigned)type
2720 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2722 return newLISTOP(type, 0, first, last);
2725 if (first->op_flags & OPf_KIDS)
2726 ((LISTOP*)first)->op_last->op_sibling = last;
2728 first->op_flags |= OPf_KIDS;
2729 ((LISTOP*)first)->op_first = last;
2731 ((LISTOP*)first)->op_last = last;
2736 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2744 if (first->op_type != (unsigned)type)
2745 return prepend_elem(type, (OP*)first, (OP*)last);
2747 if (last->op_type != (unsigned)type)
2748 return append_elem(type, (OP*)first, (OP*)last);
2750 first->op_last->op_sibling = last->op_first;
2751 first->op_last = last->op_last;
2752 first->op_flags |= (last->op_flags & OPf_KIDS);
2755 if (last->op_first && first->op_madprop) {
2756 MADPROP *mp = last->op_first->op_madprop;
2758 while (mp->mad_next)
2760 mp->mad_next = first->op_madprop;
2763 last->op_first->op_madprop = first->op_madprop;
2766 first->op_madprop = last->op_madprop;
2767 last->op_madprop = 0;
2770 S_op_destroy(aTHX_ (OP*)last);
2776 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2784 if (last->op_type == (unsigned)type) {
2785 if (type == OP_LIST) { /* already a PUSHMARK there */
2786 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2787 ((LISTOP*)last)->op_first->op_sibling = first;
2788 if (!(first->op_flags & OPf_PARENS))
2789 last->op_flags &= ~OPf_PARENS;
2792 if (!(last->op_flags & OPf_KIDS)) {
2793 ((LISTOP*)last)->op_last = first;
2794 last->op_flags |= OPf_KIDS;
2796 first->op_sibling = ((LISTOP*)last)->op_first;
2797 ((LISTOP*)last)->op_first = first;
2799 last->op_flags |= OPf_KIDS;
2803 return newLISTOP(type, 0, first, last);
2811 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2814 Newxz(tk, 1, TOKEN);
2815 tk->tk_type = (OPCODE)optype;
2816 tk->tk_type = 12345;
2818 tk->tk_mad = madprop;
2823 Perl_token_free(pTHX_ TOKEN* tk)
2825 PERL_ARGS_ASSERT_TOKEN_FREE;
2827 if (tk->tk_type != 12345)
2829 mad_free(tk->tk_mad);
2834 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2839 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2841 if (tk->tk_type != 12345) {
2842 Perl_warner(aTHX_ packWARN(WARN_MISC),
2843 "Invalid TOKEN object ignored");
2850 /* faked up qw list? */
2852 tm->mad_type == MAD_SV &&
2853 SvPVX((SV *)tm->mad_val)[0] == 'q')
2860 /* pretend constant fold didn't happen? */
2861 if (mp->mad_key == 'f' &&
2862 (o->op_type == OP_CONST ||
2863 o->op_type == OP_GV) )
2865 token_getmad(tk,(OP*)mp->mad_val,slot);
2879 if (mp->mad_key == 'X')
2880 mp->mad_key = slot; /* just change the first one */
2890 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2899 /* pretend constant fold didn't happen? */
2900 if (mp->mad_key == 'f' &&
2901 (o->op_type == OP_CONST ||
2902 o->op_type == OP_GV) )
2904 op_getmad(from,(OP*)mp->mad_val,slot);
2911 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2914 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2920 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2929 /* pretend constant fold didn't happen? */
2930 if (mp->mad_key == 'f' &&
2931 (o->op_type == OP_CONST ||
2932 o->op_type == OP_GV) )
2934 op_getmad(from,(OP*)mp->mad_val,slot);
2941 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2944 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2948 PerlIO_printf(PerlIO_stderr(),
2949 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2955 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2973 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2977 addmad(tm, &(o->op_madprop), slot);
2981 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3002 Perl_newMADsv(pTHX_ char key, SV* sv)
3004 PERL_ARGS_ASSERT_NEWMADSV;
3006 return newMADPROP(key, MAD_SV, sv, 0);
3010 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3013 Newxz(mp, 1, MADPROP);
3016 mp->mad_vlen = vlen;
3017 mp->mad_type = type;
3019 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3024 Perl_mad_free(pTHX_ MADPROP* mp)
3026 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3030 mad_free(mp->mad_next);
3031 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3032 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3033 switch (mp->mad_type) {
3037 Safefree((char*)mp->mad_val);
3040 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3041 op_free((OP*)mp->mad_val);
3044 sv_free(MUTABLE_SV(mp->mad_val));
3047 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3056 =head1 Optree construction
3058 =for apidoc Am|OP *|newNULLLIST
3060 Constructs, checks, and returns a new C<stub> op, which represents an
3061 empty list expression.
3067 Perl_newNULLLIST(pTHX)
3069 return newOP(OP_STUB, 0);
3073 S_force_list(pTHX_ OP *o)
3075 if (!o || o->op_type != OP_LIST)
3076 o = newLISTOP(OP_LIST, 0, o, NULL);
3082 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3084 Constructs, checks, and returns an op of any list type. I<type> is
3085 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3086 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3087 supply up to two ops to be direct children of the list op; they are
3088 consumed by this function and become part of the constructed op tree.
3094 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3099 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3101 NewOp(1101, listop, 1, LISTOP);
3103 listop->op_type = (OPCODE)type;
3104 listop->op_ppaddr = PL_ppaddr[type];
3107 listop->op_flags = (U8)flags;
3111 else if (!first && last)
3114 first->op_sibling = last;
3115 listop->op_first = first;
3116 listop->op_last = last;
3117 if (type == OP_LIST) {
3118 OP* const pushop = newOP(OP_PUSHMARK, 0);
3119 pushop->op_sibling = first;
3120 listop->op_first = pushop;
3121 listop->op_flags |= OPf_KIDS;
3123 listop->op_last = pushop;
3126 return CHECKOP(type, listop);
3130 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3132 Constructs, checks, and returns an op of any base type (any type that
3133 has no extra fields). I<type> is the opcode. I<flags> gives the
3134 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3141 Perl_newOP(pTHX_ I32 type, I32 flags)
3146 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3147 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3148 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3149 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3151 NewOp(1101, o, 1, OP);
3152 o->op_type = (OPCODE)type;
3153 o->op_ppaddr = PL_ppaddr[type];
3154 o->op_flags = (U8)flags;
3156 o->op_latefreed = 0;
3160 o->op_private = (U8)(0 | (flags >> 8));
3161 if (PL_opargs[type] & OA_RETSCALAR)
3163 if (PL_opargs[type] & OA_TARGET)
3164 o->op_targ = pad_alloc(type, SVs_PADTMP);
3165 return CHECKOP(type, o);
3169 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3171 Constructs, checks, and returns an op of any unary type. I<type> is
3172 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3173 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3174 bits, the eight bits of C<op_private>, except that the bit with value 1
3175 is automatically set. I<first> supplies an optional op to be the direct
3176 child of the unary op; it is consumed by this function and become part
3177 of the constructed op tree.
3183 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3188 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3189 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3190 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3191 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3192 || type == OP_SASSIGN
3193 || type == OP_ENTERTRY
3194 || type == OP_NULL );
3197 first = newOP(OP_STUB, 0);
3198 if (PL_opargs[type] & OA_MARK)
3199 first = force_list(first);
3201 NewOp(1101, unop, 1, UNOP);
3202 unop->op_type = (OPCODE)type;
3203 unop->op_ppaddr = PL_ppaddr[type];
3204 unop->op_first = first;
3205 unop->op_flags = (U8)(flags | OPf_KIDS);
3206 unop->op_private = (U8)(1 | (flags >> 8));
3207 unop = (UNOP*) CHECKOP(type, unop);
3211 return fold_constants((OP *) unop);
3215 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3217 Constructs, checks, and returns an op of any binary type. I<type>
3218 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3219 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3220 the eight bits of C<op_private>, except that the bit with value 1 or
3221 2 is automatically set as required. I<first> and I<last> supply up to
3222 two ops to be the direct children of the binary op; they are consumed
3223 by this function and become part of the constructed op tree.
3229 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3234 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3235 || type == OP_SASSIGN || type == OP_NULL );
3237 NewOp(1101, binop, 1, BINOP);
3240 first = newOP(OP_NULL, 0);
3242 binop->op_type = (OPCODE)type;
3243 binop->op_ppaddr = PL_ppaddr[type];
3244 binop->op_first = first;
3245 binop->op_flags = (U8)(flags | OPf_KIDS);
3248 binop->op_private = (U8)(1 | (flags >> 8));
3251 binop->op_private = (U8)(2 | (flags >> 8));
3252 first->op_sibling = last;
3255 binop = (BINOP*)CHECKOP(type, binop);
3256 if (binop->op_next || binop->op_type != (OPCODE)type)
3259 binop->op_last = binop->op_first->op_sibling;
3261 return fold_constants((OP *)binop);
3264 static int uvcompare(const void *a, const void *b)
3265 __attribute__nonnull__(1)
3266 __attribute__nonnull__(2)
3267 __attribute__pure__;
3268 static int uvcompare(const void *a, const void *b)
3270 if (*((const UV *)a) < (*(const UV *)b))
3272 if (*((const UV *)a) > (*(const UV *)b))
3274 if (*((const UV *)a+1) < (*(const UV *)b+1))
3276 if (*((const UV *)a+1) > (*(const UV *)b+1))
3282 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3285 SV * const tstr = ((SVOP*)expr)->op_sv;
3288 (repl->op_type == OP_NULL)
3289 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3291 ((SVOP*)repl)->op_sv;
3294 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3295 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3299 register short *tbl;
3301 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3302 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3303 I32 del = o->op_private & OPpTRANS_DELETE;
3306 PERL_ARGS_ASSERT_PMTRANS;
3308 PL_hints |= HINT_BLOCK_SCOPE;
3311 o->op_private |= OPpTRANS_FROM_UTF;
3314 o->op_private |= OPpTRANS_TO_UTF;
3316 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3317 SV* const listsv = newSVpvs("# comment\n");
3319 const U8* tend = t + tlen;
3320 const U8* rend = r + rlen;
3334 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3335 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3338 const U32 flags = UTF8_ALLOW_DEFAULT;
3342 t = tsave = bytes_to_utf8(t, &len);
3345 if (!to_utf && rlen) {
3347 r = rsave = bytes_to_utf8(r, &len);
3351 /* There are several snags with this code on EBCDIC:
3352 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3353 2. scan_const() in toke.c has encoded chars in native encoding which makes
3354 ranges at least in EBCDIC 0..255 range the bottom odd.
3358 U8 tmpbuf[UTF8_MAXBYTES+1];
3361 Newx(cp, 2*tlen, UV);
3363 transv = newSVpvs("");
3365 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3367 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3369 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3373 cp[2*i+1] = cp[2*i];
3377 qsort(cp, i, 2*sizeof(UV), uvcompare);
3378 for (j = 0; j < i; j++) {
3380 diff = val - nextmin;
3382 t = uvuni_to_utf8(tmpbuf,nextmin);
3383 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3385 U8 range_mark = UTF_TO_NATIVE(0xff);
3386 t = uvuni_to_utf8(tmpbuf, val - 1);
3387 sv_catpvn(transv, (char *)&range_mark, 1);
3388 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3395 t = uvuni_to_utf8(tmpbuf,nextmin);
3396 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3398 U8 range_mark = UTF_TO_NATIVE(0xff);
3399 sv_catpvn(transv, (char *)&range_mark, 1);
3401 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3402 UNICODE_ALLOW_SUPER);
3403 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3404 t = (const U8*)SvPVX_const(transv);
3405 tlen = SvCUR(transv);
3409 else if (!rlen && !del) {
3410 r = t; rlen = tlen; rend = tend;
3413 if ((!rlen && !del) || t == r ||
3414 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3416 o->op_private |= OPpTRANS_IDENTICAL;
3420 while (t < tend || tfirst <= tlast) {
3421 /* see if we need more "t" chars */
3422 if (tfirst > tlast) {
3423 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3425 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3427 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3434 /* now see if we need more "r" chars */
3435 if (rfirst > rlast) {
3437 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3439 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3441 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3450 rfirst = rlast = 0xffffffff;
3454 /* now see which range will peter our first, if either. */
3455 tdiff = tlast - tfirst;
3456 rdiff = rlast - rfirst;
3463 if (rfirst == 0xffffffff) {
3464 diff = tdiff; /* oops, pretend rdiff is infinite */
3466 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3467 (long)tfirst, (long)tlast);
3469 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3473 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3474 (long)tfirst, (long)(tfirst + diff),
3477 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3478 (long)tfirst, (long)rfirst);
3480 if (rfirst + diff > max)
3481 max = rfirst + diff;
3483 grows = (tfirst < rfirst &&
3484 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3496 else if (max > 0xff)
3501 PerlMemShared_free(cPVOPo->op_pv);
3502 cPVOPo->op_pv = NULL;
3504 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3506 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3507 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3508 PAD_SETSV(cPADOPo->op_padix, swash);
3510 SvREADONLY_on(swash);
3512 cSVOPo->op_sv = swash;
3514 SvREFCNT_dec(listsv);
3515 SvREFCNT_dec(transv);
3517 if (!del && havefinal && rlen)
3518 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3519 newSVuv((UV)final), 0);
3522 o->op_private |= OPpTRANS_GROWS;
3528 op_getmad(expr,o,'e');
3529 op_getmad(repl,o,'r');
3537 tbl = (short*)cPVOPo->op_pv;
3539 Zero(tbl, 256, short);
3540 for (i = 0; i < (I32)tlen; i++)
3542 for (i = 0, j = 0; i < 256; i++) {
3544 if (j >= (I32)rlen) {
3553 if (i < 128 && r[j] >= 128)
3563 o->op_private |= OPpTRANS_IDENTICAL;
3565 else if (j >= (I32)rlen)
3570 PerlMemShared_realloc(tbl,
3571 (0x101+rlen-j) * sizeof(short));
3572 cPVOPo->op_pv = (char*)tbl;
3574 tbl[0x100] = (short)(rlen - j);
3575 for (i=0; i < (I32)rlen - j; i++)
3576 tbl[0x101+i] = r[j+i];
3580 if (!rlen && !del) {
3583 o->op_private |= OPpTRANS_IDENTICAL;
3585 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3586 o->op_private |= OPpTRANS_IDENTICAL;
3588 for (i = 0; i < 256; i++)
3590 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3591 if (j >= (I32)rlen) {
3593 if (tbl[t[i]] == -1)
3599 if (tbl[t[i]] == -1) {
3600 if (t[i] < 128 && r[j] >= 128)
3607 if(del && rlen == tlen) {
3608 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3609 } else if(rlen > tlen) {
3610 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3614 o->op_private |= OPpTRANS_GROWS;
3616 op_getmad(expr,o,'e');
3617 op_getmad(repl,o,'r');
3627 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3629 Constructs, checks, and returns an op of any pattern matching type.
3630 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
3631 and, shifted up eight bits, the eight bits of C<op_private>.
3637 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3642 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3644 NewOp(1101, pmop, 1, PMOP);
3645 pmop->op_type = (OPCODE)type;
3646 pmop->op_ppaddr = PL_ppaddr[type];
3647 pmop->op_flags = (U8)flags;
3648 pmop->op_private = (U8)(0 | (flags >> 8));
3650 if (PL_hints & HINT_RE_TAINT)
3651 pmop->op_pmflags |= PMf_RETAINT;
3652 if (PL_hints & HINT_LOCALE) {
3653 pmop->op_pmflags |= PMf_LOCALE;
3655 else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3656 pmop->op_pmflags |= RXf_PMf_UNICODE;
3661 assert(SvPOK(PL_regex_pad[0]));
3662 if (SvCUR(PL_regex_pad[0])) {
3663 /* Pop off the "packed" IV from the end. */
3664 SV *const repointer_list = PL_regex_pad[0];
3665 const char *p = SvEND(repointer_list) - sizeof(IV);
3666 const IV offset = *((IV*)p);
3668 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3670 SvEND_set(repointer_list, p);
3672 pmop->op_pmoffset = offset;
3673 /* This slot should be free, so assert this: */
3674 assert(PL_regex_pad[offset] == &PL_sv_undef);
3676 SV * const repointer = &PL_sv_undef;
3677 av_push(PL_regex_padav, repointer);
3678 pmop->op_pmoffset = av_len(PL_regex_padav);
3679 PL_regex_pad = AvARRAY(PL_regex_padav);
3683 return CHECKOP(type, pmop);
3686 /* Given some sort of match op o, and an expression expr containing a
3687 * pattern, either compile expr into a regex and attach it to o (if it's
3688 * constant), or convert expr into a runtime regcomp op sequence (if it's
3691 * isreg indicates that the pattern is part of a regex construct, eg
3692 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3693 * split "pattern", which aren't. In the former case, expr will be a list
3694 * if the pattern contains more than one term (eg /a$b/) or if it contains
3695 * a replacement, ie s/// or tr///.
3699 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3704 I32 repl_has_vars = 0;
3708 PERL_ARGS_ASSERT_PMRUNTIME;
3710 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3711 /* last element in list is the replacement; pop it */
3713 repl = cLISTOPx(expr)->op_last;
3714 kid = cLISTOPx(expr)->op_first;
3715 while (kid->op_sibling != repl)
3716 kid = kid->op_sibling;
3717 kid->op_sibling = NULL;
3718 cLISTOPx(expr)->op_last = kid;
3721 if (isreg && expr->op_type == OP_LIST &&
3722 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3724 /* convert single element list to element */
3725 OP* const oe = expr;
3726 expr = cLISTOPx(oe)->op_first->op_sibling;
3727 cLISTOPx(oe)->op_first->op_sibling = NULL;
3728 cLISTOPx(oe)->op_last = NULL;
3732 if (o->op_type == OP_TRANS) {
3733 return pmtrans(o, expr, repl);
3736 reglist = isreg && expr->op_type == OP_LIST;
3740 PL_hints |= HINT_BLOCK_SCOPE;
3743 if (expr->op_type == OP_CONST) {
3744 SV *pat = ((SVOP*)expr)->op_sv;
3745 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3747 if (o->op_flags & OPf_SPECIAL)
3748 pm_flags |= RXf_SPLIT;
3751 assert (SvUTF8(pat));
3752 } else if (SvUTF8(pat)) {
3753 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3754 trapped in use 'bytes'? */
3755 /* Make a copy of the octet sequence, but without the flag on, as
3756 the compiler now honours the SvUTF8 flag on pat. */
3758 const char *const p = SvPV(pat, len);
3759 pat = newSVpvn_flags(p, len, SVs_TEMP);
3762 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3765 op_getmad(expr,(OP*)pm,'e');
3771 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3772 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3774 : OP_REGCMAYBE),0,expr);
3776 NewOp(1101, rcop, 1, LOGOP);
3777 rcop->op_type = OP_REGCOMP;
3778 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3779 rcop->op_first = scalar(expr);
3780 rcop->op_flags |= OPf_KIDS
3781 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3782 | (reglist ? OPf_STACKED : 0);
3783 rcop->op_private = 1;
3786 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3788 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3791 /* establish postfix order */
3792 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3794 rcop->op_next = expr;
3795 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3798 rcop->op_next = LINKLIST(expr);
3799 expr->op_next = (OP*)rcop;
3802 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3807 if (pm->op_pmflags & PMf_EVAL) {
3809 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3810 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3812 else if (repl->op_type == OP_CONST)
3816 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3817 if (curop->op_type == OP_SCOPE
3818 || curop->op_type == OP_LEAVE
3819 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3820 if (curop->op_type == OP_GV) {
3821 GV * const gv = cGVOPx_gv(curop);
3823 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3826 else if (curop->op_type == OP_RV2CV)
3828 else if (curop->op_type == OP_RV2SV ||
3829 curop->op_type == OP_RV2AV ||
3830 curop->op_type == OP_RV2HV ||
3831 curop->op_type == OP_RV2GV) {
3832 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3835 else if (curop->op_type == OP_PADSV ||
3836 curop->op_type == OP_PADAV ||
3837 curop->op_type == OP_PADHV ||
3838 curop->op_type == OP_PADANY)
3842 else if (curop->op_type == OP_PUSHRE)
3843 NOOP; /* Okay here, dangerous in newASSIGNOP */
3853 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3855 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3856 prepend_elem(o->op_type, scalar(repl), o);
3859 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3860 pm->op_pmflags |= PMf_MAYBE_CONST;
3862 NewOp(1101, rcop, 1, LOGOP);
3863 rcop->op_type = OP_SUBSTCONT;
3864 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3865 rcop->op_first = scalar(repl);
3866 rcop->op_flags |= OPf_KIDS;
3867 rcop->op_private = 1;
3870 /* establish postfix order */
3871 rcop->op_next = LINKLIST(repl);
3872 repl->op_next = (OP*)rcop;
3874 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3875 assert(!(pm->op_pmflags & PMf_ONCE));
3876 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3885 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3887 Constructs, checks, and returns an op of any type that involves an
3888 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
3889 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
3890 takes ownership of one reference to it.
3896 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3901 PERL_ARGS_ASSERT_NEWSVOP;
3903 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3904 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3905 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3907 NewOp(1101, svop, 1, SVOP);
3908 svop->op_type = (OPCODE)type;
3909 svop->op_ppaddr = PL_ppaddr[type];
3911 svop->op_next = (OP*)svop;
3912 svop->op_flags = (U8)flags;
3913 if (PL_opargs[type] & OA_RETSCALAR)
3915 if (PL_opargs[type] & OA_TARGET)
3916 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3917 return CHECKOP(type, svop);
3923 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
3925 Constructs, checks, and returns an op of any type that involves a
3926 reference to a pad element. I<type> is the opcode. I<flags> gives the
3927 eight bits of C<op_flags>. A pad slot is automatically allocated, and
3928 is populated with I<sv>; this function takes ownership of one reference
3931 This function only exists if Perl has been compiled to use ithreads.
3937 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3942 PERL_ARGS_ASSERT_NEWPADOP;
3944 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3945 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3946 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3948 NewOp(1101, padop, 1, PADOP);
3949 padop->op_type = (OPCODE)type;
3950 padop->op_ppaddr = PL_ppaddr[type];
3951 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3952 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3953 PAD_SETSV(padop->op_padix, sv);
3956 padop->op_next = (OP*)padop;
3957 padop->op_flags = (U8)flags;
3958 if (PL_opargs[type] & OA_RETSCALAR)
3960 if (PL_opargs[type] & OA_TARGET)
3961 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3962 return CHECKOP(type, padop);
3965 #endif /* !USE_ITHREADS */
3968 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
3970 Constructs, checks, and returns an op of any type that involves an
3971 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
3972 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
3973 reference; calling this function does not transfer ownership of any
3980 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3984 PERL_ARGS_ASSERT_NEWGVOP;
3988 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3990 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3995 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
3997 Constructs, checks, and returns an op of any type that involves an
3998 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
3999 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4000 must have been allocated using L</PerlMemShared_malloc>; the memory will
4001 be freed when the op is destroyed.
4007 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4012 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4013 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4015 NewOp(1101, pvop, 1, PVOP);
4016 pvop->op_type = (OPCODE)type;
4017 pvop->op_ppaddr = PL_ppaddr[type];
4019 pvop->op_next = (OP*)pvop;
4020 pvop->op_flags = (U8)flags;
4021 if (PL_opargs[type] & OA_RETSCALAR)
4023 if (PL_opargs[type] & OA_TARGET)
4024 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4025 return CHECKOP(type, pvop);
4033 Perl_package(pTHX_ OP *o)
4036 SV *const sv = cSVOPo->op_sv;
4041 PERL_ARGS_ASSERT_PACKAGE;
4043 save_hptr(&PL_curstash);
4044 save_item(PL_curstname);
4046 PL_curstash = gv_stashsv(sv, GV_ADD);
4048 sv_setsv(PL_curstname, sv);
4050 PL_hints |= HINT_BLOCK_SCOPE;
4051 PL_parser->copline = NOLINE;
4052 PL_parser->expect = XSTATE;
4057 if (!PL_madskills) {
4062 pegop = newOP(OP_NULL,0);
4063 op_getmad(o,pegop,'P');
4069 Perl_package_version( pTHX_ OP *v )
4072 U32 savehints = PL_hints;
4073 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4074 PL_hints &= ~HINT_STRICT_VARS;
4075 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4076 PL_hints = savehints;
4085 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4092 OP *pegop = newOP(OP_NULL,0);
4095 PERL_ARGS_ASSERT_UTILIZE;
4097 if (idop->op_type != OP_CONST)
4098 Perl_croak(aTHX_ "Module name must be constant");
4101 op_getmad(idop,pegop,'U');
4106 SV * const vesv = ((SVOP*)version)->op_sv;
4109 op_getmad(version,pegop,'V');
4110 if (!arg && !SvNIOKp(vesv)) {
4117 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4118 Perl_croak(aTHX_ "Version number must be a constant number");
4120 /* Make copy of idop so we don't free it twice */
4121 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4123 /* Fake up a method call to VERSION */
4124 meth = newSVpvs_share("VERSION");
4125 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4126 append_elem(OP_LIST,
4127 prepend_elem(OP_LIST, pack, list(version)),
4128 newSVOP(OP_METHOD_NAMED, 0, meth)));
4132 /* Fake up an import/unimport */
4133 if (arg && arg->op_type == OP_STUB) {
4135 op_getmad(arg,pegop,'S');
4136 imop = arg; /* no import on explicit () */
4138 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4139 imop = NULL; /* use 5.0; */
4141 idop->op_private |= OPpCONST_NOVER;
4147 op_getmad(arg,pegop,'A');
4149 /* Make copy of idop so we don't free it twice */
4150 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4152 /* Fake up a method call to import/unimport */
4154 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4155 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4156 append_elem(OP_LIST,
4157 prepend_elem(OP_LIST, pack, list(arg)),
4158 newSVOP(OP_METHOD_NAMED, 0, meth)));
4161 /* Fake up the BEGIN {}, which does its thing immediately. */
4163 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4166 append_elem(OP_LINESEQ,
4167 append_elem(OP_LINESEQ,
4168 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4169 newSTATEOP(0, NULL, veop)),
4170 newSTATEOP(0, NULL, imop) ));
4172 /* The "did you use incorrect case?" warning used to be here.
4173 * The problem is that on case-insensitive filesystems one
4174 * might get false positives for "use" (and "require"):
4175 * "use Strict" or "require CARP" will work. This causes
4176 * portability problems for the script: in case-strict
4177 * filesystems the script will stop working.
4179 * The "incorrect case" warning checked whether "use Foo"
4180 * imported "Foo" to your namespace, but that is wrong, too:
4181 * there is no requirement nor promise in the language that
4182 * a Foo.pm should or would contain anything in package "Foo".
4184 * There is very little Configure-wise that can be done, either:
4185 * the case-sensitivity of the build filesystem of Perl does not
4186 * help in guessing the case-sensitivity of the runtime environment.
4189 PL_hints |= HINT_BLOCK_SCOPE;
4190 PL_parser->copline = NOLINE;
4191 PL_parser->expect = XSTATE;
4192 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4195 if (!PL_madskills) {
4196 /* FIXME - don't allocate pegop if !PL_madskills */
4205 =head1 Embedding Functions
4207 =for apidoc load_module
4209 Loads the module whose name is pointed to by the string part of name.
4210 Note that the actual module name, not its filename, should be given.
4211 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4212 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4213 (or 0 for no flags). ver, if specified, provides version semantics
4214 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4215 arguments can be used to specify arguments to the module's import()
4216 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4217 terminated with a final NULL pointer. Note that this list can only
4218 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4219 Otherwise at least a single NULL pointer to designate the default
4220 import list is required.
4225 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4229 PERL_ARGS_ASSERT_LOAD_MODULE;
4231 va_start(args, ver);
4232 vload_module(flags, name, ver, &args);
4236 #ifdef PERL_IMPLICIT_CONTEXT
4238 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4242 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4243 va_start(args, ver);
4244 vload_module(flags, name, ver, &args);
4250 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4254 OP * const modname = newSVOP(OP_CONST, 0, name);
4256 PERL_ARGS_ASSERT_VLOAD_MODULE;
4258 modname->op_private |= OPpCONST_BARE;
4260 veop = newSVOP(OP_CONST, 0, ver);
4264 if (flags & PERL_LOADMOD_NOIMPORT) {
4265 imop = sawparens(newNULLLIST());
4267 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4268 imop = va_arg(*args, OP*);
4273 sv = va_arg(*args, SV*);
4275 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4276 sv = va_arg(*args, SV*);
4280 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4281 * that it has a PL_parser to play with while doing that, and also
4282 * that it doesn't mess with any existing parser, by creating a tmp
4283 * new parser with lex_start(). This won't actually be used for much,
4284 * since pp_require() will create another parser for the real work. */
4287 SAVEVPTR(PL_curcop);
4288 lex_start(NULL, NULL, FALSE);
4289 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4290 veop, modname, imop);
4295 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4301 PERL_ARGS_ASSERT_DOFILE;
4303 if (!force_builtin) {
4304 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4305 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4306 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4307 gv = gvp ? *gvp : NULL;
4311 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4312 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4313 append_elem(OP_LIST, term,
4314 scalar(newUNOP(OP_RV2CV, 0,
4315 newGVOP(OP_GV, 0, gv))))));
4318 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4324 =head1 Optree construction
4326 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4328 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4329 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4330 be set automatically, and, shifted up eight bits, the eight bits of
4331 C<op_private>, except that the bit with value 1 or 2 is automatically
4332 set as required. I<listval> and I<subscript> supply the parameters of
4333 the slice; they are consumed by this function and become part of the
4334 constructed op tree.
4340 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4342 return newBINOP(OP_LSLICE, flags,
4343 list(force_list(subscript)),
4344 list(force_list(listval)) );
4348 S_is_list_assignment(pTHX_ register const OP *o)
4356 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4357 o = cUNOPo->op_first;
4359 flags = o->op_flags;
4361 if (type == OP_COND_EXPR) {
4362 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4363 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4368 yyerror("Assignment to both a list and a scalar");
4372 if (type == OP_LIST &&
4373 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4374 o->op_private & OPpLVAL_INTRO)
4377 if (type == OP_LIST || flags & OPf_PARENS ||
4378 type == OP_RV2AV || type == OP_RV2HV ||
4379 type == OP_ASLICE || type == OP_HSLICE)
4382 if (type == OP_PADAV || type == OP_PADHV)
4385 if (type == OP_RV2SV)
4392 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4394 Constructs, checks, and returns an assignment op. I<left> and I<right>
4395 supply the parameters of the assignment; they are consumed by this
4396 function and become part of the constructed op tree.
4398 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4399 a suitable conditional optree is constructed. If I<optype> is the opcode
4400 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4401 performs the binary operation and assigns the result to the left argument.
4402 Either way, if I<optype> is non-zero then I<flags> has no effect.
4404 If I<optype> is zero, then a plain scalar or list assignment is
4405 constructed. Which type of assignment it is is automatically determined.
4406 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4407 will be set automatically, and, shifted up eight bits, the eight bits
4408 of C<op_private>, except that the bit with value 1 or 2 is automatically
4415 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4421 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4422 return newLOGOP(optype, 0,
4423 mod(scalar(left), optype),
4424 newUNOP(OP_SASSIGN, 0, scalar(right)));
4427 return newBINOP(optype, OPf_STACKED,
4428 mod(scalar(left), optype), scalar(right));
4432 if (is_list_assignment(left)) {
4433 static const char no_list_state[] = "Initialization of state variables"
4434 " in list context currently forbidden";
4436 bool maybe_common_vars = TRUE;
4439 /* Grandfathering $[ assignment here. Bletch.*/
4440 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4441 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4442 left = mod(left, OP_AASSIGN);
4445 else if (left->op_type == OP_CONST) {
4446 deprecate("assignment to $[");
4448 /* Result of assignment is always 1 (or we'd be dead already) */
4449 return newSVOP(OP_CONST, 0, newSViv(1));
4451 curop = list(force_list(left));
4452 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4453 o->op_private = (U8)(0 | (flags >> 8));
4455 if ((left->op_type == OP_LIST
4456 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4458 OP* lop = ((LISTOP*)left)->op_first;
4459 maybe_common_vars = FALSE;
4461 if (lop->op_type == OP_PADSV ||
4462 lop->op_type == OP_PADAV ||
4463 lop->op_type == OP_PADHV ||
4464 lop->op_type == OP_PADANY) {
4465 if (!(lop->op_private & OPpLVAL_INTRO))
4466 maybe_common_vars = TRUE;
4468 if (lop->op_private & OPpPAD_STATE) {
4469 if (left->op_private & OPpLVAL_INTRO) {
4470 /* Each variable in state($a, $b, $c) = ... */
4473 /* Each state variable in
4474 (state $a, my $b, our $c, $d, undef) = ... */
4476 yyerror(no_list_state);
4478 /* Each my variable in
4479 (state $a, my $b, our $c, $d, undef) = ... */
4481 } else if (lop->op_type == OP_UNDEF ||
4482 lop->op_type == OP_PUSHMARK) {
4483 /* undef may be interesting in
4484 (state $a, undef, state $c) */
4486 /* Other ops in the list. */
4487 maybe_common_vars = TRUE;
4489 lop = lop->op_sibling;
4492 else if ((left->op_private & OPpLVAL_INTRO)
4493 && ( left->op_type == OP_PADSV
4494 || left->op_type == OP_PADAV
4495 || left->op_type == OP_PADHV
4496 || left->op_type == OP_PADANY))
4498 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4499 if (left->op_private & OPpPAD_STATE) {
4500 /* All single variable list context state assignments, hence
4510 yyerror(no_list_state);
4514 /* PL_generation sorcery:
4515 * an assignment like ($a,$b) = ($c,$d) is easier than
4516 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4517 * To detect whether there are common vars, the global var
4518 * PL_generation is incremented for each assign op we compile.
4519 * Then, while compiling the assign op, we run through all the
4520 * variables on both sides of the assignment, setting a spare slot
4521 * in each of them to PL_generation. If any of them already have
4522 * that value, we know we've got commonality. We could use a
4523 * single bit marker, but then we'd have to make 2 passes, first
4524 * to clear the flag, then to test and set it. To find somewhere
4525 * to store these values, evil chicanery is done with SvUVX().
4528 if (maybe_common_vars) {
4531 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4532 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4533 if (curop->op_type == OP_GV) {
4534 GV *gv = cGVOPx_gv(curop);
4536 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4538 GvASSIGN_GENERATION_set(gv, PL_generation);
4540 else if (curop->op_type == OP_PADSV ||
4541 curop->op_type == OP_PADAV ||
4542 curop->op_type == OP_PADHV ||
4543 curop->op_type == OP_PADANY)
4545 if (PAD_COMPNAME_GEN(curop->op_targ)
4546 == (STRLEN)PL_generation)
4548 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4551 else if (curop->op_type == OP_RV2CV)
4553 else if (curop->op_type == OP_RV2SV ||
4554 curop->op_type == OP_RV2AV ||
4555 curop->op_type == OP_RV2HV ||
4556 curop->op_type == OP_RV2GV) {
4557 if (lastop->op_type != OP_GV) /* funny deref? */
4560 else if (curop->op_type == OP_PUSHRE) {
4562 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4563 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4565 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4567 GvASSIGN_GENERATION_set(gv, PL_generation);
4571 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4574 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4576 GvASSIGN_GENERATION_set(gv, PL_generation);
4586 o->op_private |= OPpASSIGN_COMMON;
4589 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4590 OP* tmpop = ((LISTOP*)right)->op_first;
4591 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4592 PMOP * const pm = (PMOP*)tmpop;
4593 if (left->op_type == OP_RV2AV &&
4594 !(left->op_private & OPpLVAL_INTRO) &&
4595 !(o->op_private & OPpASSIGN_COMMON) )
4597 tmpop = ((UNOP*)left)->op_first;
4598 if (tmpop->op_type == OP_GV
4600 && !pm->op_pmreplrootu.op_pmtargetoff
4602 && !pm->op_pmreplrootu.op_pmtargetgv
4606 pm->op_pmreplrootu.op_pmtargetoff
4607 = cPADOPx(tmpop)->op_padix;
4608 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4610 pm->op_pmreplrootu.op_pmtargetgv
4611 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4612 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4614 pm->op_pmflags |= PMf_ONCE;
4615 tmpop = cUNOPo->op_first; /* to list (nulled) */
4616 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4617 tmpop->op_sibling = NULL; /* don't free split */
4618 right->op_next = tmpop->op_next; /* fix starting loc */
4619 op_free(o); /* blow off assign */
4620 right->op_flags &= ~OPf_WANT;
4621 /* "I don't know and I don't care." */
4626 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4627 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4629 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4630 if (SvIOK(sv) && SvIVX(sv) == 0)
4631 sv_setiv(sv, PL_modcount+1);
4639 right = newOP(OP_UNDEF, 0);
4640 if (right->op_type == OP_READLINE) {
4641 right->op_flags |= OPf_STACKED;
4642 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4645 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4646 o = newBINOP(OP_SASSIGN, flags,
4647 scalar(right), mod(scalar(left), OP_SASSIGN) );
4651 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4652 deprecate("assignment to $[");
4654 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4655 o->op_private |= OPpCONST_ARYBASE;
4663 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4665 Constructs a state op (COP). The state op is normally a C<nextstate> op,
4666 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4667 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4668 If I<label> is non-null, it supplies the name of a label to attach to
4669 the state op; this function takes ownership of the memory pointed at by
4670 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
4673 If I<o> is null, the state op is returned. Otherwise the state op is
4674 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
4675 is consumed by this function and becomes part of the returned op tree.
4681 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4684 const U32 seq = intro_my();
4687 NewOp(1101, cop, 1, COP);
4688 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4689 cop->op_type = OP_DBSTATE;
4690 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4693 cop->op_type = OP_NEXTSTATE;
4694 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4696 cop->op_flags = (U8)flags;
4697 CopHINTS_set(cop, PL_hints);
4699 cop->op_private |= NATIVE_HINTS;
4701 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4702 cop->op_next = (OP*)cop;
4705 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4706 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4708 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4709 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4710 if (cop->cop_hints_hash) {
4712 cop->cop_hints_hash->refcounted_he_refcnt++;
4713 HINTS_REFCNT_UNLOCK;
4716 Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4718 PL_hints |= HINT_BLOCK_SCOPE;
4719 /* It seems that we need to defer freeing this pointer, as other parts
4720 of the grammar end up wanting to copy it after this op has been
4725 if (PL_parser && PL_parser->copline == NOLINE)
4726 CopLINE_set(cop, CopLINE(PL_curcop));
4728 CopLINE_set(cop, PL_parser->copline);
4730 PL_parser->copline = NOLINE;
4733 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4735 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4737 CopSTASH_set(cop, PL_curstash);
4739 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4740 /* this line can have a breakpoint - store the cop in IV */
4741 AV *av = CopFILEAVx(PL_curcop);
4743 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4744 if (svp && *svp != &PL_sv_undef ) {
4745 (void)SvIOK_on(*svp);
4746 SvIV_set(*svp, PTR2IV(cop));
4751 if (flags & OPf_SPECIAL)
4753 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4757 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4759 Constructs, checks, and returns a logical (flow control) op. I<type>
4760 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4761 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4762 the eight bits of C<op_private>, except that the bit with value 1 is
4763 automatically set. I<first> supplies the expression controlling the
4764 flow, and I<other> supplies the side (alternate) chain of ops; they are
4765 consumed by this function and become part of the constructed op tree.
4771 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4775 PERL_ARGS_ASSERT_NEWLOGOP;
4777 return new_logop(type, flags, &first, &other);
4781 S_search_const(pTHX_ OP *o)
4783 PERL_ARGS_ASSERT_SEARCH_CONST;
4785 switch (o->op_type) {
4789 if (o->op_flags & OPf_KIDS)
4790 return search_const(cUNOPo->op_first);
4797 if (!(o->op_flags & OPf_KIDS))
4799 kid = cLISTOPo->op_first;
4801 switch (kid->op_type) {
4805 kid = kid->op_sibling;
4808 if (kid != cLISTOPo->op_last)
4814 kid = cLISTOPo->op_last;
4816 return search_const(kid);
4824 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4832 int prepend_not = 0;
4834 PERL_ARGS_ASSERT_NEW_LOGOP;
4839 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4840 return newBINOP(type, flags, scalar(first), scalar(other));
4842 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4844 scalarboolean(first);
4845 /* optimize AND and OR ops that have NOTs as children */
4846 if (first->op_type == OP_NOT
4847 && (first->op_flags & OPf_KIDS)
4848 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4849 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4851 if (type == OP_AND || type == OP_OR) {
4857 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4859 prepend_not = 1; /* prepend a NOT op later */
4863 /* search for a constant op that could let us fold the test */
4864 if ((cstop = search_const(first))) {
4865 if (cstop->op_private & OPpCONST_STRICT)
4866 no_bareword_allowed(cstop);
4867 else if ((cstop->op_private & OPpCONST_BARE))
4868 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4869 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4870 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4871 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4873 if (other->op_type == OP_CONST)
4874 other->op_private |= OPpCONST_SHORTCIRCUIT;
4876 OP *newop = newUNOP(OP_NULL, 0, other);
4877 op_getmad(first, newop, '1');
4878 newop->op_targ = type; /* set "was" field */
4882 if (other->op_type == OP_LEAVE)
4883 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4884 else if (other->op_type == OP_MATCH
4885 || other->op_type == OP_SUBST
4886 || other->op_type == OP_TRANS)
4887 /* Mark the op as being unbindable with =~ */
4888 other->op_flags |= OPf_SPECIAL;
4892 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4893 const OP *o2 = other;
4894 if ( ! (o2->op_type == OP_LIST
4895 && (( o2 = cUNOPx(o2)->op_first))
4896 && o2->op_type == OP_PUSHMARK
4897 && (( o2 = o2->op_sibling)) )
4900 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4901 || o2->op_type == OP_PADHV)
4902 && o2->op_private & OPpLVAL_INTRO
4903 && !(o2->op_private & OPpPAD_STATE))
4905 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4906 "Deprecated use of my() in false conditional");
4910 if (first->op_type == OP_CONST)
4911 first->op_private |= OPpCONST_SHORTCIRCUIT;
4913 first = newUNOP(OP_NULL, 0, first);
4914 op_getmad(other, first, '2');
4915 first->op_targ = type; /* set "was" field */
4922 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4923 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4925 const OP * const k1 = ((UNOP*)first)->op_first;
4926 const OP * const k2 = k1->op_sibling;
4928 switch (first->op_type)
4931 if (k2 && k2->op_type == OP_READLINE
4932 && (k2->op_flags & OPf_STACKED)
4933 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4935 warnop = k2->op_type;
4940 if (k1->op_type == OP_READDIR
4941 || k1->op_type == OP_GLOB
4942 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4943 || k1->op_type == OP_EACH)
4945 warnop = ((k1->op_type == OP_NULL)
4946 ? (OPCODE)k1->op_targ : k1->op_type);
4951 const line_t oldline = CopLINE(PL_curcop);
4952 CopLINE_set(PL_curcop, PL_parser->copline);
4953 Perl_warner(aTHX_ packWARN(WARN_MISC),
4954 "Value of %s%s can be \"0\"; test with defined()",
4956 ((warnop == OP_READLINE || warnop == OP_GLOB)
4957 ? " construct" : "() operator"));
4958 CopLINE_set(PL_curcop, oldline);
4965 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4966 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4968 NewOp(1101, logop, 1, LOGOP);
4970 logop->op_type = (OPCODE)type;
4971 logop->op_ppaddr = PL_ppaddr[type];
4972 logop->op_first = first;
4973 logop->op_flags = (U8)(flags | OPf_KIDS);
4974 logop->op_other = LINKLIST(other);
4975 logop->op_private = (U8)(1 | (flags >> 8));
4977 /* establish postfix order */
4978 logop->op_next = LINKLIST(first);
4979 first->op_next = (OP*)logop;
4980 first->op_sibling = other;
4982 CHECKOP(type,logop);
4984 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4991 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
4993 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
4994 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4995 will be set automatically, and, shifted up eight bits, the eight bits of
4996 C<op_private>, except that the bit with value 1 is automatically set.
4997 I<first> supplies the expression selecting between the two branches,
4998 and I<trueop> and I<falseop> supply the branches; they are consumed by
4999 this function and become part of the constructed op tree.
5005 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5013 PERL_ARGS_ASSERT_NEWCONDOP;
5016 return newLOGOP(OP_AND, 0, first, trueop);
5018 return newLOGOP(OP_OR, 0, first, falseop);
5020 scalarboolean(first);
5021 if ((cstop = search_const(first))) {
5022 /* Left or right arm of the conditional? */
5023 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5024 OP *live = left ? trueop : falseop;
5025 OP *const dead = left ? falseop : trueop;
5026 if (cstop->op_private & OPpCONST_BARE &&
5027 cstop->op_private & OPpCONST_STRICT) {
5028 no_bareword_allowed(cstop);
5031 /* This is all dead code when PERL_MAD is not defined. */
5032 live = newUNOP(OP_NULL, 0, live);
5033 op_getmad(first, live, 'C');
5034 op_getmad(dead, live, left ? 'e' : 't');
5039 if (live->op_type == OP_LEAVE)
5040 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5041 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5042 || live->op_type == OP_TRANS)
5043 /* Mark the op as being unbindable with =~ */
5044 live->op_flags |= OPf_SPECIAL;
5047 NewOp(1101, logop, 1, LOGOP);
5048 logop->op_type = OP_COND_EXPR;
5049 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5050 logop->op_first = first;
5051 logop->op_flags = (U8)(flags | OPf_KIDS);
5052 logop->op_private = (U8)(1 | (flags >> 8));
5053 logop->op_other = LINKLIST(trueop);
5054 logop->op_next = LINKLIST(falseop);
5056 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5059 /* establish postfix order */
5060 start = LINKLIST(first);
5061 first->op_next = (OP*)logop;
5063 first->op_sibling = trueop;
5064 trueop->op_sibling = falseop;
5065 o = newUNOP(OP_NULL, 0, (OP*)logop);
5067 trueop->op_next = falseop->op_next = o;
5074 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5076 Constructs and returns a C<range> op, with subordinate C<flip> and
5077 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5078 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5079 for both the C<flip> and C<range> ops, except that the bit with value
5080 1 is automatically set. I<left> and I<right> supply the expressions
5081 controlling the endpoints of the range; they are consumed by this function
5082 and become part of the constructed op tree.
5088 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5097 PERL_ARGS_ASSERT_NEWRANGE;
5099 NewOp(1101, range, 1, LOGOP);
5101 range->op_type = OP_RANGE;
5102 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5103 range->op_first = left;
5104 range->op_flags = OPf_KIDS;
5105 leftstart = LINKLIST(left);
5106 range->op_other = LINKLIST(right);
5107 range->op_private = (U8)(1 | (flags >> 8));
5109 left->op_sibling = right;
5111 range->op_next = (OP*)range;
5112 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5113 flop = newUNOP(OP_FLOP, 0, flip);
5114 o = newUNOP(OP_NULL, 0, flop);
5116 range->op_next = leftstart;
5118 left->op_next = flip;
5119 right->op_next = flop;
5121 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5122 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5123 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5124 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5126 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5127 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5130 if (!flip->op_private || !flop->op_private)
5131 linklist(o); /* blow off optimizer unless constant */
5137 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5139 Constructs, checks, and returns an op tree expressing a loop. This is
5140 only a loop in the control flow through the op tree; it does not have
5141 the heavyweight loop structure that allows exiting the loop by C<last>
5142 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5143 top-level op, except that some bits will be set automatically as required.
5144 I<expr> supplies the expression controlling loop iteration, and I<block>
5145 supplies the body of the loop; they are consumed by this function and
5146 become part of the constructed op tree. I<debuggable> is currently
5147 unused and should always be 1.
5153 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5158 const bool once = block && block->op_flags & OPf_SPECIAL &&
5159 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5161 PERL_UNUSED_ARG(debuggable);
5164 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5165 return block; /* do {} while 0 does once */
5166 if (expr->op_type == OP_READLINE
5167 || expr->op_type == OP_READDIR
5168 || expr->op_type == OP_GLOB
5169 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5170 expr = newUNOP(OP_DEFINED, 0,
5171 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5172 } else if (expr->op_flags & OPf_KIDS) {
5173 const OP * const k1 = ((UNOP*)expr)->op_first;
5174 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5175 switch (expr->op_type) {
5177 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5178 && (k2->op_flags & OPf_STACKED)
5179 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5180 expr = newUNOP(OP_DEFINED, 0, expr);
5184 if (k1 && (k1->op_type == OP_READDIR
5185 || k1->op_type == OP_GLOB
5186 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5187 || k1->op_type == OP_EACH))
5188 expr = newUNOP(OP_DEFINED, 0, expr);
5194 /* if block is null, the next append_elem() would put UNSTACK, a scalar
5195 * op, in listop. This is wrong. [perl #27024] */
5197 block = newOP(OP_NULL, 0);
5198 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5199 o = new_logop(OP_AND, 0, &expr, &listop);
5202 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5204 if (once && o != listop)
5205 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5208 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5210 o->op_flags |= flags;
5212 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5217 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
5219 Constructs, checks, and returns an op tree expressing a C<while> loop.
5220 This is a heavyweight loop, with structure that allows exiting the loop
5221 by C<last> and suchlike.
5223 I<loop> is an optional preconstructed C<enterloop> op to use in the
5224 loop; if it is null then a suitable op will be constructed automatically.
5225 I<expr> supplies the loop's controlling expression. I<block> supplies the
5226 main body of the loop, and I<cont> optionally supplies a C<continue> block
5227 that operates as a second half of the body. All of these optree inputs
5228 are consumed by this function and become part of the constructed op tree.
5230 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5231 op and, shifted up eight bits, the eight bits of C<op_private> for
5232 the C<leaveloop> op, except that (in both cases) some bits will be set
5233 automatically. I<debuggable> is currently unused and should always be 1.
5234 I<whileline> is the line number that should be attributed to the loop's
5235 controlling expression. I<has_my> can be supplied as true to force the
5236 loop body to be enclosed in its own scope.
5242 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
5243 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
5252 PERL_UNUSED_ARG(debuggable);
5255 if (expr->op_type == OP_READLINE
5256 || expr->op_type == OP_READDIR
5257 || expr->op_type == OP_GLOB
5258 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5259 expr = newUNOP(OP_DEFINED, 0,
5260 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5261 } else if (expr->op_flags & OPf_KIDS) {
5262 const OP * const k1 = ((UNOP*)expr)->op_first;
5263 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5264 switch (expr->op_type) {
5266 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5267 && (k2->op_flags & OPf_STACKED)
5268 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5269 expr = newUNOP(OP_DEFINED, 0, expr);
5273 if (k1 && (k1->op_type == OP_READDIR
5274 || k1->op_type == OP_GLOB
5275 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5276 || k1->op_type == OP_EACH))
5277 expr = newUNOP(OP_DEFINED, 0, expr);
5284 block = newOP(OP_NULL, 0);
5285 else if (cont || has_my) {
5286 block = scope(block);
5290 next = LINKLIST(cont);
5293 OP * const unstack = newOP(OP_UNSTACK, 0);
5296 cont = append_elem(OP_LINESEQ, cont, unstack);
5300 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
5302 redo = LINKLIST(listop);
5305 PL_parser->copline = (line_t)whileline;
5307 o = new_logop(OP_AND, 0, &expr, &listop);
5308 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5309 op_free(expr); /* oops, it's a while (0) */
5311 return NULL; /* listop already freed by new_logop */
5314 ((LISTOP*)listop)->op_last->op_next =
5315 (o == listop ? redo : LINKLIST(o));
5321 NewOp(1101,loop,1,LOOP);
5322 loop->op_type = OP_ENTERLOOP;
5323 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5324 loop->op_private = 0;
5325 loop->op_next = (OP*)loop;
5328 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5330 loop->op_redoop = redo;
5331 loop->op_lastop = o;
5332 o->op_private |= loopflags;
5335 loop->op_nextop = next;
5337 loop->op_nextop = o;
5339 o->op_flags |= flags;
5340 o->op_private |= (flags >> 8);
5345 =for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
5347 Constructs, checks, and returns an op tree expressing a C<foreach>
5348 loop (iteration through a list of values). This is a heavyweight loop,
5349 with structure that allows exiting the loop by C<last> and suchlike.
5351 I<sv> optionally supplies the variable that will be aliased to each
5352 item in turn; if null, it defaults to C<$_> (either lexical or global).
5353 I<expr> supplies the list of values to iterate over. I<block> supplies
5354 the main body of the loop, and I<cont> optionally supplies a C<continue>
5355 block that operates as a second half of the body. All of these optree
5356 inputs are consumed by this function and become part of the constructed
5359 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5360 op and, shifted up eight bits, the eight bits of C<op_private> for
5361 the C<leaveloop> op, except that (in both cases) some bits will be set
5362 automatically. I<forline> is the line number that should be attributed
5363 to the loop's list expression. If I<label> is non-null, it supplies
5364 the name of a label to attach to the state op at the start of the loop;
5365 this function takes ownership of the memory pointed at by I<label>,
5372 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5377 PADOFFSET padoff = 0;
5382 PERL_ARGS_ASSERT_NEWFOROP;
5385 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5386 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5387 sv->op_type = OP_RV2GV;
5388 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5390 /* The op_type check is needed to prevent a possible segfault
5391 * if the loop variable is undeclared and 'strict vars' is in
5392 * effect. This is illegal but is nonetheless parsed, so we
5393 * may reach this point with an OP_CONST where we're expecting
5396 if (cUNOPx(sv)->op_first->op_type == OP_GV
5397 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5398 iterpflags |= OPpITER_DEF;
5400 else if (sv->op_type == OP_PADSV) { /* private variable */
5401 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5402 padoff = sv->op_targ;
5412 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5414 SV *const namesv = PAD_COMPNAME_SV(padoff);
5416 const char *const name = SvPV_const(namesv, len);
5418 if (len == 2 && name[0] == '$' && name[1] == '_')
5419 iterpflags |= OPpITER_DEF;
5423 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5424 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5425 sv = newGVOP(OP_GV, 0, PL_defgv);
5430 iterpflags |= OPpITER_DEF;
5432 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5433 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5434 iterflags |= OPf_STACKED;
5436 else if (expr->op_type == OP_NULL &&
5437 (expr->op_flags & OPf_KIDS) &&
5438 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5440 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5441 * set the STACKED flag to indicate that these values are to be
5442 * treated as min/max values by 'pp_iterinit'.
5444 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5445 LOGOP* const range = (LOGOP*) flip->op_first;
5446 OP* const left = range->op_first;
5447 OP* const right = left->op_sibling;
5450 range->op_flags &= ~OPf_KIDS;
5451 range->op_first = NULL;
5453 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5454 listop->op_first->op_next = range->op_next;
5455 left->op_next = range->op_other;
5456 right->op_next = (OP*)listop;
5457 listop->op_next = listop->op_first;
5460 op_getmad(expr,(OP*)listop,'O');
5464 expr = (OP*)(listop);
5466 iterflags |= OPf_STACKED;
5469 expr = mod(force_list(expr), OP_GREPSTART);
5472 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5473 append_elem(OP_LIST, expr, scalar(sv))));
5474 assert(!loop->op_next);
5475 /* for my $x () sets OPpLVAL_INTRO;
5476 * for our $x () sets OPpOUR_INTRO */
5477 loop->op_private = (U8)iterpflags;
5478 #ifdef PL_OP_SLAB_ALLOC
5481 NewOp(1234,tmp,1,LOOP);
5482 Copy(loop,tmp,1,LISTOP);
5483 S_op_destroy(aTHX_ (OP*)loop);
5487 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5489 loop->op_targ = padoff;
5490 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5492 op_getmad(madsv, (OP*)loop, 'v');
5493 PL_parser->copline = forline;
5494 return newSTATEOP(0, label, wop);
5498 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5500 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5501 or C<last>). I<type> is the opcode. I<label> supplies the parameter
5502 determining the target of the op; it is consumed by this function and
5503 become part of the constructed op tree.
5509 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5514 PERL_ARGS_ASSERT_NEWLOOPEX;
5516 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5518 if (type != OP_GOTO || label->op_type == OP_CONST) {
5519 /* "last()" means "last" */
5520 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5521 o = newOP(type, OPf_SPECIAL);
5523 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5524 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5528 op_getmad(label,o,'L');
5534 /* Check whether it's going to be a goto &function */
5535 if (label->op_type == OP_ENTERSUB
5536 && !(label->op_flags & OPf_STACKED))
5537 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5538 o = newUNOP(type, OPf_STACKED, label);
5540 PL_hints |= HINT_BLOCK_SCOPE;
5544 /* if the condition is a literal array or hash
5545 (or @{ ... } etc), make a reference to it.
5548 S_ref_array_or_hash(pTHX_ OP *cond)
5551 && (cond->op_type == OP_RV2AV
5552 || cond->op_type == OP_PADAV
5553 || cond->op_type == OP_RV2HV
5554 || cond->op_type == OP_PADHV))
5556 return newUNOP(OP_REFGEN,
5557 0, mod(cond, OP_REFGEN));
5560 && (cond->op_type == OP_ASLICE
5561 || cond->op_type == OP_HSLICE)) {
5563 /* anonlist now needs a list from this op, was previously used in
5565 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5566 cond->op_flags |= OPf_WANT_LIST;
5568 return newANONLIST(mod(cond, OP_ANONLIST));
5575 /* These construct the optree fragments representing given()
5578 entergiven and enterwhen are LOGOPs; the op_other pointer
5579 points up to the associated leave op. We need this so we
5580 can put it in the context and make break/continue work.
5581 (Also, of course, pp_enterwhen will jump straight to
5582 op_other if the match fails.)
5586 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5587 I32 enter_opcode, I32 leave_opcode,
5588 PADOFFSET entertarg)
5594 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5596 NewOp(1101, enterop, 1, LOGOP);
5597 enterop->op_type = (Optype)enter_opcode;
5598 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5599 enterop->op_flags = (U8) OPf_KIDS;
5600 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5601 enterop->op_private = 0;
5603 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5606 enterop->op_first = scalar(cond);
5607 cond->op_sibling = block;
5609 o->op_next = LINKLIST(cond);
5610 cond->op_next = (OP *) enterop;
5613 /* This is a default {} block */
5614 enterop->op_first = block;
5615 enterop->op_flags |= OPf_SPECIAL;
5617 o->op_next = (OP *) enterop;
5620 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5621 entergiven and enterwhen both
5624 enterop->op_next = LINKLIST(block);
5625 block->op_next = enterop->op_other = o;
5630 /* Does this look like a boolean operation? For these purposes
5631 a boolean operation is:
5632 - a subroutine call [*]
5633 - a logical connective
5634 - a comparison operator
5635 - a filetest operator, with the exception of -s -M -A -C
5636 - defined(), exists() or eof()
5637 - /$re/ or $foo =~ /$re/
5639 [*] possibly surprising
5642 S_looks_like_bool(pTHX_ const OP *o)
5646 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5648 switch(o->op_type) {
5651 return looks_like_bool(cLOGOPo->op_first);
5655 looks_like_bool(cLOGOPo->op_first)
5656 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5661 o->op_flags & OPf_KIDS
5662 && looks_like_bool(cUNOPo->op_first));
5666 case OP_NOT: case OP_XOR:
5668 case OP_EQ: case OP_NE: case OP_LT:
5669 case OP_GT: case OP_LE: case OP_GE:
5671 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5672 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5674 case OP_SEQ: case OP_SNE: case OP_SLT:
5675 case OP_SGT: case OP_SLE: case OP_SGE:
5679 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5680 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5681 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5682 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5683 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5684 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5685 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5686 case OP_FTTEXT: case OP_FTBINARY:
5688 case OP_DEFINED: case OP_EXISTS:
5689 case OP_MATCH: case OP_EOF:
5696 /* Detect comparisons that have been optimized away */
5697 if (cSVOPo->op_sv == &PL_sv_yes
5698 || cSVOPo->op_sv == &PL_sv_no)
5711 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5713 Constructs, checks, and returns an op tree expressing a C<given> block.
5714 I<cond> supplies the expression that will be locally assigned to a lexical
5715 variable, and I<block> supplies the body of the C<given> construct; they
5716 are consumed by this function and become part of the constructed op tree.
5717 I<defsv_off> is the pad offset of the scalar lexical variable that will
5724 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5727 PERL_ARGS_ASSERT_NEWGIVENOP;
5728 return newGIVWHENOP(
5729 ref_array_or_hash(cond),
5731 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5736 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5738 Constructs, checks, and returns an op tree expressing a C<when> block.
5739 I<cond> supplies the test expression, and I<block> supplies the block
5740 that will be executed if the test evaluates to true; they are consumed
5741 by this function and become part of the constructed op tree. I<cond>
5742 will be interpreted DWIMically, often as a comparison against C<$_>,
5743 and may be null to generate a C<default> block.
5749 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5751 const bool cond_llb = (!cond || looks_like_bool(cond));
5754 PERL_ARGS_ASSERT_NEWWHENOP;
5759 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5761 scalar(ref_array_or_hash(cond)));
5764 return newGIVWHENOP(
5766 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5767 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5771 =head1 Embedding Functions
5773 =for apidoc cv_undef
5775 Clear out all the active components of a CV. This can happen either
5776 by an explicit C<undef &foo>, or by the reference count going to zero.
5777 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5778 children can still follow the full lexical scope chain.
5784 Perl_cv_undef(pTHX_ CV *cv)
5788 PERL_ARGS_ASSERT_CV_UNDEF;
5790 DEBUG_X(PerlIO_printf(Perl_debug_log,
5791 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5792 PTR2UV(cv), PTR2UV(PL_comppad))
5796 if (CvFILE(cv) && !CvISXSUB(cv)) {
5797 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5798 Safefree(CvFILE(cv));
5803 if (!CvISXSUB(cv) && CvROOT(cv)) {
5804 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5805 Perl_croak(aTHX_ "Can't undef active subroutine");
5808 PAD_SAVE_SETNULLPAD();
5810 op_free(CvROOT(cv));
5815 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5820 /* remove CvOUTSIDE unless this is an undef rather than a free */
5821 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5822 if (!CvWEAKOUTSIDE(cv))
5823 SvREFCNT_dec(CvOUTSIDE(cv));
5824 CvOUTSIDE(cv) = NULL;
5827 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5830 if (CvISXSUB(cv) && CvXSUB(cv)) {
5833 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5834 * ref status of CvOUTSIDE and CvGV */
5835 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5839 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5842 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5844 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5845 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5846 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5847 || (p && (len != SvCUR(cv) /* Not the same length. */
5848 || memNE(p, SvPVX_const(cv), len))))
5849 && ckWARN_d(WARN_PROTOTYPE)) {
5850 SV* const msg = sv_newmortal();
5854 gv_efullname3(name = sv_newmortal(), gv, NULL);
5855 sv_setpvs(msg, "Prototype mismatch:");
5857 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5859 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5861 sv_catpvs(msg, ": none");
5862 sv_catpvs(msg, " vs ");
5864 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5866 sv_catpvs(msg, "none");
5867 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5871 static void const_sv_xsub(pTHX_ CV* cv);
5875 =head1 Optree Manipulation Functions
5877 =for apidoc cv_const_sv
5879 If C<cv> is a constant sub eligible for inlining. returns the constant
5880 value returned by the sub. Otherwise, returns NULL.
5882 Constant subs can be created with C<newCONSTSUB> or as described in
5883 L<perlsub/"Constant Functions">.
5888 Perl_cv_const_sv(pTHX_ const CV *const cv)
5890 PERL_UNUSED_CONTEXT;
5893 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5895 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5898 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5899 * Can be called in 3 ways:
5902 * look for a single OP_CONST with attached value: return the value
5904 * cv && CvCLONE(cv) && !CvCONST(cv)
5906 * examine the clone prototype, and if contains only a single
5907 * OP_CONST referencing a pad const, or a single PADSV referencing
5908 * an outer lexical, return a non-zero value to indicate the CV is
5909 * a candidate for "constizing" at clone time
5913 * We have just cloned an anon prototype that was marked as a const
5914 * candidiate. Try to grab the current value, and in the case of
5915 * PADSV, ignore it if it has multiple references. Return the value.
5919 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5930 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5931 o = cLISTOPo->op_first->op_sibling;
5933 for (; o; o = o->op_next) {
5934 const OPCODE type = o->op_type;
5936 if (sv && o->op_next == o)
5938 if (o->op_next != o) {
5939 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5941 if (type == OP_DBSTATE)
5944 if (type == OP_LEAVESUB || type == OP_RETURN)
5948 if (type == OP_CONST && cSVOPo->op_sv)
5950 else if (cv && type == OP_CONST) {
5951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5955 else if (cv && type == OP_PADSV) {
5956 if (CvCONST(cv)) { /* newly cloned anon */
5957 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5958 /* the candidate should have 1 ref from this pad and 1 ref
5959 * from the parent */
5960 if (!sv || SvREFCNT(sv) != 2)
5967 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5968 sv = &PL_sv_undef; /* an arbitrary non-null value */
5983 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5986 /* This would be the return value, but the return cannot be reached. */
5987 OP* pegop = newOP(OP_NULL, 0);
5990 PERL_UNUSED_ARG(floor);
6000 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6002 NORETURN_FUNCTION_END;
6007 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6009 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6013 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6018 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6019 register CV *cv = NULL;
6021 /* If the subroutine has no body, no attributes, and no builtin attributes
6022 then it's just a sub declaration, and we may be able to get away with
6023 storing with a placeholder scalar in the symbol table, rather than a
6024 full GV and CV. If anything is present then it will take a full CV to
6026 const I32 gv_fetch_flags
6027 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6029 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6030 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6034 assert(proto->op_type == OP_CONST);
6035 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6041 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6043 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6044 SV * const sv = sv_newmortal();
6045 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6046 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6047 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6048 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6050 } else if (PL_curstash) {
6051 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6054 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6058 if (!PL_madskills) {
6067 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6068 maximum a prototype before. */
6069 if (SvTYPE(gv) > SVt_NULL) {
6070 if (!SvPOK((const SV *)gv)
6071 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6073 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6075 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6078 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6080 sv_setiv(MUTABLE_SV(gv), -1);
6082 SvREFCNT_dec(PL_compcv);
6083 cv = PL_compcv = NULL;
6087 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6089 if (!block || !ps || *ps || attrs
6090 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6092 || block->op_type == OP_NULL
6097 const_sv = op_const_sv(block, NULL);
6100 const bool exists = CvROOT(cv) || CvXSUB(cv);
6102 /* if the subroutine doesn't exist and wasn't pre-declared
6103 * with a prototype, assume it will be AUTOLOADed,
6104 * skipping the prototype check
6106 if (exists || SvPOK(cv))
6107 cv_ckproto_len(cv, gv, ps, ps_len);
6108 /* already defined (or promised)? */
6109 if (exists || GvASSUMECV(gv)) {
6112 || block->op_type == OP_NULL
6115 if (CvFLAGS(PL_compcv)) {
6116 /* might have had built-in attrs applied */
6117 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6118 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6119 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6121 /* just a "sub foo;" when &foo is already defined */
6122 SAVEFREESV(PL_compcv);
6127 && block->op_type != OP_NULL
6130 if (ckWARN(WARN_REDEFINE)
6132 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6134 const line_t oldline = CopLINE(PL_curcop);
6135 if (PL_parser && PL_parser->copline != NOLINE)
6136 CopLINE_set(PL_curcop, PL_parser->copline);
6137 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6138 CvCONST(cv) ? "Constant subroutine %s redefined"
6139 : "Subroutine %s redefined", name);
6140 CopLINE_set(PL_curcop, oldline);
6143 if (!PL_minus_c) /* keep old one around for madskills */
6146 /* (PL_madskills unset in used file.) */
6154 SvREFCNT_inc_simple_void_NN(const_sv);
6156 assert(!CvROOT(cv) && !CvCONST(cv));
6157 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6158 CvXSUBANY(cv).any_ptr = const_sv;
6159 CvXSUB(cv) = const_sv_xsub;
6165 cv = newCONSTSUB(NULL, name, const_sv);
6167 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6168 (CvGV(cv) && GvSTASH(CvGV(cv)))
6177 SvREFCNT_dec(PL_compcv);
6181 if (cv) { /* must reuse cv if autoloaded */
6182 /* transfer PL_compcv to cv */
6185 && block->op_type != OP_NULL
6188 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6190 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6191 if (!CvWEAKOUTSIDE(cv))
6192 SvREFCNT_dec(CvOUTSIDE(cv));
6193 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6194 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6195 CvOUTSIDE(PL_compcv) = 0;
6196 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6197 CvPADLIST(PL_compcv) = 0;
6198 /* inner references to PL_compcv must be fixed up ... */
6199 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6200 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6201 ++PL_sub_generation;
6203 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
6206 /* Might have had built-in attributes applied -- propagate them. */
6207 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6209 /* ... before we throw it away */
6210 SvREFCNT_dec(PL_compcv);
6218 if (strEQ(name, "import")) {
6219 PL_formfeed = MUTABLE_SV(cv);
6220 /* diag_listed_as: SKIPME */
6221 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6225 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6230 CvFILE_set_from_cop(cv, PL_curcop);
6231 CvSTASH(cv) = PL_curstash;
6233 Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
6236 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6237 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6238 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6242 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6244 if (PL_parser && PL_parser->error_count) {
6248 const char *s = strrchr(name, ':');
6250 if (strEQ(s, "BEGIN")) {
6251 const char not_safe[] =
6252 "BEGIN not safe after errors--compilation aborted";
6253 if (PL_in_eval & EVAL_KEEPERR)
6254 Perl_croak(aTHX_ not_safe);
6256 /* force display of errors found but not reported */
6257 sv_catpv(ERRSV, not_safe);
6258 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6267 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6268 the debugger could be able to set a breakpoint in, so signal to
6269 pp_entereval that it should not throw away any saved lines at scope
6272 PL_breakable_sub_gen++;
6274 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6275 mod(scalarseq(block), OP_LEAVESUBLV));
6276 block->op_attached = 1;
6279 /* This makes sub {}; work as expected. */
6280 if (block->op_type == OP_STUB) {
6281 OP* const newblock = newSTATEOP(0, NULL, 0);
6283 op_getmad(block,newblock,'B');
6290 block->op_attached = 1;
6291 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6293 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6294 OpREFCNT_set(CvROOT(cv), 1);
6295 CvSTART(cv) = LINKLIST(CvROOT(cv));
6296 CvROOT(cv)->op_next = 0;
6297 CALL_PEEP(CvSTART(cv));
6299 /* now that optimizer has done its work, adjust pad values */
6301 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6304 assert(!CvCONST(cv));
6305 if (ps && !*ps && op_const_sv(block, cv))
6310 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6311 SV * const tmpstr = sv_newmortal();
6312 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6313 GV_ADDMULTI, SVt_PVHV);
6315 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6318 (long)CopLINE(PL_curcop));
6319 gv_efullname3(tmpstr, gv, NULL);
6320 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6321 SvCUR(tmpstr), sv, 0);
6322 hv = GvHVn(db_postponed);
6323 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6324 CV * const pcv = GvCV(db_postponed);
6330 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6335 if (name && ! (PL_parser && PL_parser->error_count))
6336 process_special_blocks(name, gv, cv);
6341 PL_parser->copline = NOLINE;
6347 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6350 const char *const colon = strrchr(fullname,':');
6351 const char *const name = colon ? colon + 1 : fullname;
6353 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6356 if (strEQ(name, "BEGIN")) {
6357 const I32 oldscope = PL_scopestack_ix;
6359 SAVECOPFILE(&PL_compiling);
6360 SAVECOPLINE(&PL_compiling);
6362 DEBUG_x( dump_sub(gv) );
6363 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6364 GvCV(gv) = 0; /* cv has been hijacked */
6365 call_list(oldscope, PL_beginav);
6367 PL_curcop = &PL_compiling;
6368 CopHINTS_set(&PL_compiling, PL_hints);
6375 if strEQ(name, "END") {
6376 DEBUG_x( dump_sub(gv) );
6377 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6380 } else if (*name == 'U') {
6381 if (strEQ(name, "UNITCHECK")) {
6382 /* It's never too late to run a unitcheck block */
6383 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6387 } else if (*name == 'C') {
6388 if (strEQ(name, "CHECK")) {
6390 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6391 "Too late to run CHECK block");
6392 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6396 } else if (*name == 'I') {
6397 if (strEQ(name, "INIT")) {
6399 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6400 "Too late to run INIT block");
6401 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6407 DEBUG_x( dump_sub(gv) );
6408 GvCV(gv) = 0; /* cv has been hijacked */
6413 =for apidoc newCONSTSUB
6415 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6416 eligible for inlining at compile-time.
6418 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6419 which won't be called if used as a destructor, but will suppress the overhead
6420 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6427 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6432 const char *const file = CopFILE(PL_curcop);
6434 SV *const temp_sv = CopFILESV(PL_curcop);
6435 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6440 if (IN_PERL_RUNTIME) {
6441 /* at runtime, it's not safe to manipulate PL_curcop: it may be
6442 * an op shared between threads. Use a non-shared COP for our
6444 SAVEVPTR(PL_curcop);
6445 PL_curcop = &PL_compiling;
6447 SAVECOPLINE(PL_curcop);
6448 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6451 PL_hints &= ~HINT_BLOCK_SCOPE;
6454 SAVESPTR(PL_curstash);
6455 SAVECOPSTASH(PL_curcop);
6456 PL_curstash = stash;
6457 CopSTASH_set(PL_curcop,stash);
6460 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6461 and so doesn't get free()d. (It's expected to be from the C pre-
6462 processor __FILE__ directive). But we need a dynamically allocated one,
6463 and we need it to get freed. */
6464 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6465 XS_DYNAMIC_FILENAME);
6466 CvXSUBANY(cv).any_ptr = sv;
6471 CopSTASH_free(PL_curcop);
6479 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6480 const char *const filename, const char *const proto,
6483 CV *cv = newXS(name, subaddr, filename);
6485 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6487 if (flags & XS_DYNAMIC_FILENAME) {
6488 /* We need to "make arrangements" (ie cheat) to ensure that the
6489 filename lasts as long as the PVCV we just created, but also doesn't
6491 STRLEN filename_len = strlen(filename);
6492 STRLEN proto_and_file_len = filename_len;
6493 char *proto_and_file;
6497 proto_len = strlen(proto);
6498 proto_and_file_len += proto_len;
6500 Newx(proto_and_file, proto_and_file_len + 1, char);
6501 Copy(proto, proto_and_file, proto_len, char);
6502 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6505 proto_and_file = savepvn(filename, filename_len);
6508 /* This gets free()d. :-) */
6509 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6510 SV_HAS_TRAILING_NUL);
6512 /* This gives us the correct prototype, rather than one with the
6513 file name appended. */
6514 SvCUR_set(cv, proto_len);
6518 CvFILE(cv) = proto_and_file + proto_len;
6520 sv_setpv(MUTABLE_SV(cv), proto);
6526 =for apidoc U||newXS
6528 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6529 static storage, as it is used directly as CvFILE(), without a copy being made.
6535 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6538 GV * const gv = gv_fetchpv(name ? name :
6539 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6540 GV_ADDMULTI, SVt_PVCV);
6543 PERL_ARGS_ASSERT_NEWXS;
6546 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6548 if ((cv = (name ? GvCV(gv) : NULL))) {
6550 /* just a cached method */
6554 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6555 /* already defined (or promised) */
6556 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6557 if (ckWARN(WARN_REDEFINE)) {
6558 GV * const gvcv = CvGV(cv);
6560 HV * const stash = GvSTASH(gvcv);
6562 const char *redefined_name = HvNAME_get(stash);
6563 if ( strEQ(redefined_name,"autouse") ) {
6564 const line_t oldline = CopLINE(PL_curcop);
6565 if (PL_parser && PL_parser->copline != NOLINE)
6566 CopLINE_set(PL_curcop, PL_parser->copline);
6567 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6568 CvCONST(cv) ? "Constant subroutine %s redefined"
6569 : "Subroutine %s redefined"
6571 CopLINE_set(PL_curcop, oldline);
6581 if (cv) /* must reuse cv if autoloaded */
6584 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6588 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6594 (void)gv_fetchfile(filename);
6595 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6596 an external constant string */
6598 CvXSUB(cv) = subaddr;
6601 process_special_blocks(name, gv, cv);
6611 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6616 OP* pegop = newOP(OP_NULL, 0);
6620 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6621 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6624 if ((cv = GvFORM(gv))) {
6625 if (ckWARN(WARN_REDEFINE)) {
6626 const line_t oldline = CopLINE(PL_curcop);
6627 if (PL_parser && PL_parser->copline != NOLINE)
6628 CopLINE_set(PL_curcop, PL_parser->copline);
6630 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6631 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6633 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6634 "Format STDOUT redefined");
6636 CopLINE_set(PL_curcop, oldline);
6643 CvFILE_set_from_cop(cv, PL_curcop);
6646 pad_tidy(padtidy_FORMAT);
6647 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6648 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6649 OpREFCNT_set(CvROOT(cv), 1);
6650 CvSTART(cv) = LINKLIST(CvROOT(cv));
6651 CvROOT(cv)->op_next = 0;
6652 CALL_PEEP(CvSTART(cv));
6654 op_getmad(o,pegop,'n');
6655 op_getmad_weak(block, pegop, 'b');
6660 PL_parser->copline = NOLINE;
6668 Perl_newANONLIST(pTHX_ OP *o)
6670 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6674 Perl_newANONHASH(pTHX_ OP *o)
6676 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6680 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6682 return newANONATTRSUB(floor, proto, NULL, block);
6686 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6688 return newUNOP(OP_REFGEN, 0,
6689 newSVOP(OP_ANONCODE, 0,
6690 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6694 Perl_oopsAV(pTHX_ OP *o)
6698 PERL_ARGS_ASSERT_OOPSAV;
6700 switch (o->op_type) {
6702 o->op_type = OP_PADAV;
6703 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6704 return ref(o, OP_RV2AV);
6707 o->op_type = OP_RV2AV;
6708 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6713 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6720 Perl_oopsHV(pTHX_ OP *o)
6724 PERL_ARGS_ASSERT_OOPSHV;
6726 switch (o->op_type) {
6729 o->op_type = OP_PADHV;
6730 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6731 return ref(o, OP_RV2HV);
6735 o->op_type = OP_RV2HV;
6736 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6741 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6748 Perl_newAVREF(pTHX_ OP *o)
6752 PERL_ARGS_ASSERT_NEWAVREF;
6754 if (o->op_type == OP_PADANY) {
6755 o->op_type = OP_PADAV;
6756 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6759 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6760 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6761 "Using an array as a reference is deprecated");
6763 return newUNOP(OP_RV2AV, 0, scalar(o));
6767 Perl_newGVREF(pTHX_ I32 type, OP *o)
6769 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6770 return newUNOP(OP_NULL, 0, o);
6771 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6775 Perl_newHVREF(pTHX_ OP *o)
6779 PERL_ARGS_ASSERT_NEWHVREF;
6781 if (o->op_type == OP_PADANY) {
6782 o->op_type = OP_PADHV;
6783 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6786 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6787 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6788 "Using a hash as a reference is deprecated");
6790 return newUNOP(OP_RV2HV, 0, scalar(o));
6794 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6796 return newUNOP(OP_RV2CV, flags, scalar(o));
6800 Perl_newSVREF(pTHX_ OP *o)
6804 PERL_ARGS_ASSERT_NEWSVREF;
6806 if (o->op_type == OP_PADANY) {
6807 o->op_type = OP_PADSV;
6808 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6811 return newUNOP(OP_RV2SV, 0, scalar(o));
6814 /* Check routines. See the comments at the top of this file for details
6815 * on when these are called */
6818 Perl_ck_anoncode(pTHX_ OP *o)
6820 PERL_ARGS_ASSERT_CK_ANONCODE;
6822 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6824 cSVOPo->op_sv = NULL;
6829 Perl_ck_bitop(pTHX_ OP *o)
6833 PERL_ARGS_ASSERT_CK_BITOP;
6835 #define OP_IS_NUMCOMPARE(op) \
6836 ((op) == OP_LT || (op) == OP_I_LT || \
6837 (op) == OP_GT || (op) == OP_I_GT || \
6838 (op) == OP_LE || (op) == OP_I_LE || \
6839 (op) == OP_GE || (op) == OP_I_GE || \
6840 (op) == OP_EQ || (op) == OP_I_EQ || \
6841 (op) == OP_NE || (op) == OP_I_NE || \
6842 (op) == OP_NCMP || (op) == OP_I_NCMP)
6843 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6844 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6845 && (o->op_type == OP_BIT_OR
6846 || o->op_type == OP_BIT_AND
6847 || o->op_type == OP_BIT_XOR))
6849 const OP * const left = cBINOPo->op_first;
6850 const OP * const right = left->op_sibling;
6851 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6852 (left->op_flags & OPf_PARENS) == 0) ||
6853 (OP_IS_NUMCOMPARE(right->op_type) &&
6854 (right->op_flags & OPf_PARENS) == 0))
6855 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6856 "Possible precedence problem on bitwise %c operator",
6857 o->op_type == OP_BIT_OR ? '|'
6858 : o->op_type == OP_BIT_AND ? '&' : '^'
6865 Perl_ck_concat(pTHX_ OP *o)
6867 const OP * const kid = cUNOPo->op_first;
6869 PERL_ARGS_ASSERT_CK_CONCAT;
6870 PERL_UNUSED_CONTEXT;
6872 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6873 !(kUNOP->op_first->op_flags & OPf_MOD))
6874 o->op_flags |= OPf_STACKED;
6879 Perl_ck_spair(pTHX_ OP *o)
6883 PERL_ARGS_ASSERT_CK_SPAIR;
6885 if (o->op_flags & OPf_KIDS) {
6888 const OPCODE type = o->op_type;
6889 o = modkids(ck_fun(o), type);
6890 kid = cUNOPo->op_first;
6891 newop = kUNOP->op_first->op_sibling;
6893 const OPCODE type = newop->op_type;
6894 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6895 type == OP_PADAV || type == OP_PADHV ||
6896 type == OP_RV2AV || type == OP_RV2HV)
6900 op_getmad(kUNOP->op_first,newop,'K');
6902 op_free(kUNOP->op_first);
6904 kUNOP->op_first = newop;
6906 o->op_ppaddr = PL_ppaddr[++o->op_type];
6911 Perl_ck_delete(pTHX_ OP *o)
6913 PERL_ARGS_ASSERT_CK_DELETE;
6917 if (o->op_flags & OPf_KIDS) {
6918 OP * const kid = cUNOPo->op_first;
6919 switch (kid->op_type) {
6921 o->op_flags |= OPf_SPECIAL;
6924 o->op_private |= OPpSLICE;
6927 o->op_flags |= OPf_SPECIAL;
6932 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6935 if (kid->op_private & OPpLVAL_INTRO)
6936 o->op_private |= OPpLVAL_INTRO;
6943 Perl_ck_die(pTHX_ OP *o)
6945 PERL_ARGS_ASSERT_CK_DIE;
6948 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6954 Perl_ck_eof(pTHX_ OP *o)
6958 PERL_ARGS_ASSERT_CK_EOF;
6960 if (o->op_flags & OPf_KIDS) {
6961 if (cLISTOPo->op_first->op_type == OP_STUB) {
6963 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6965 op_getmad(o,newop,'O');
6977 Perl_ck_eval(pTHX_ OP *o)
6981 PERL_ARGS_ASSERT_CK_EVAL;
6983 PL_hints |= HINT_BLOCK_SCOPE;
6984 if (o->op_flags & OPf_KIDS) {
6985 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6988 o->op_flags &= ~OPf_KIDS;
6991 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6997 cUNOPo->op_first = 0;
7002 NewOp(1101, enter, 1, LOGOP);
7003 enter->op_type = OP_ENTERTRY;
7004 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7005 enter->op_private = 0;
7007 /* establish postfix order */
7008 enter->op_next = (OP*)enter;
7010 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7011 o->op_type = OP_LEAVETRY;
7012 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7013 enter->op_other = o;
7014 op_getmad(oldo,o,'O');
7028 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7029 op_getmad(oldo,o,'O');
7031 o->op_targ = (PADOFFSET)PL_hints;
7032 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7033 /* Store a copy of %^H that pp_entereval can pick up. */
7034 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7035 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7036 cUNOPo->op_first->op_sibling = hhop;
7037 o->op_private |= OPpEVAL_HAS_HH;
7043 Perl_ck_exit(pTHX_ OP *o)
7045 PERL_ARGS_ASSERT_CK_EXIT;
7048 HV * const table = GvHV(PL_hintgv);
7050 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7051 if (svp && *svp && SvTRUE(*svp))
7052 o->op_private |= OPpEXIT_VMSISH;
7054 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7060 Perl_ck_exec(pTHX_ OP *o)
7062 PERL_ARGS_ASSERT_CK_EXEC;
7064 if (o->op_flags & OPf_STACKED) {
7067 kid = cUNOPo->op_first->op_sibling;
7068 if (kid->op_type == OP_RV2GV)
7077 Perl_ck_exists(pTHX_ OP *o)
7081 PERL_ARGS_ASSERT_CK_EXISTS;
7084 if (o->op_flags & OPf_KIDS) {
7085 OP * const kid = cUNOPo->op_first;
7086 if (kid->op_type == OP_ENTERSUB) {
7087 (void) ref(kid, o->op_type);
7088 if (kid->op_type != OP_RV2CV
7089 && !(PL_parser && PL_parser->error_count))
7090 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7092 o->op_private |= OPpEXISTS_SUB;
7094 else if (kid->op_type == OP_AELEM)
7095 o->op_flags |= OPf_SPECIAL;
7096 else if (kid->op_type != OP_HELEM)
7097 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7105 Perl_ck_rvconst(pTHX_ register OP *o)
7108 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7110 PERL_ARGS_ASSERT_CK_RVCONST;
7112 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7113 if (o->op_type == OP_RV2CV)
7114 o->op_private &= ~1;
7116 if (kid->op_type == OP_CONST) {
7119 SV * const kidsv = kid->op_sv;
7121 /* Is it a constant from cv_const_sv()? */
7122 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7123 SV * const rsv = SvRV(kidsv);
7124 const svtype type = SvTYPE(rsv);
7125 const char *badtype = NULL;
7127 switch (o->op_type) {
7129 if (type > SVt_PVMG)
7130 badtype = "a SCALAR";
7133 if (type != SVt_PVAV)
7134 badtype = "an ARRAY";
7137 if (type != SVt_PVHV)
7141 if (type != SVt_PVCV)
7146 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7149 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7150 const char *badthing;
7151 switch (o->op_type) {
7153 badthing = "a SCALAR";
7156 badthing = "an ARRAY";
7159 badthing = "a HASH";
7167 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7168 SVfARG(kidsv), badthing);
7171 * This is a little tricky. We only want to add the symbol if we
7172 * didn't add it in the lexer. Otherwise we get duplicate strict
7173 * warnings. But if we didn't add it in the lexer, we must at
7174 * least pretend like we wanted to add it even if it existed before,
7175 * or we get possible typo warnings. OPpCONST_ENTERED says
7176 * whether the lexer already added THIS instance of this symbol.
7178 iscv = (o->op_type == OP_RV2CV) * 2;
7180 gv = gv_fetchsv(kidsv,
7181 iscv | !(kid->op_private & OPpCONST_ENTERED),
7184 : o->op_type == OP_RV2SV
7186 : o->op_type == OP_RV2AV
7188 : o->op_type == OP_RV2HV
7191 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7193 kid->op_type = OP_GV;
7194 SvREFCNT_dec(kid->op_sv);
7196 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7197 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7198 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7200 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7202 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7204 kid->op_private = 0;
7205 kid->op_ppaddr = PL_ppaddr[OP_GV];
7212 Perl_ck_ftst(pTHX_ OP *o)
7215 const I32 type = o->op_type;
7217 PERL_ARGS_ASSERT_CK_FTST;
7219 if (o->op_flags & OPf_REF) {
7222 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7223 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7224 const OPCODE kidtype = kid->op_type;
7226 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7227 OP * const newop = newGVOP(type, OPf_REF,
7228 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7230 op_getmad(o,newop,'O');
7236 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7237 o->op_private |= OPpFT_ACCESS;
7238 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
7239 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7240 o->op_private |= OPpFT_STACKED;
7248 if (type == OP_FTTTY)
7249 o = newGVOP(type, OPf_REF, PL_stdingv);
7251 o = newUNOP(type, 0, newDEFSVOP());
7252 op_getmad(oldo,o,'O');
7258 Perl_ck_fun(pTHX_ OP *o)
7261 const int type = o->op_type;
7262 register I32 oa = PL_opargs[type] >> OASHIFT;
7264 PERL_ARGS_ASSERT_CK_FUN;
7266 if (o->op_flags & OPf_STACKED) {
7267 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7270 return no_fh_allowed(o);
7273 if (o->op_flags & OPf_KIDS) {
7274 OP **tokid = &cLISTOPo->op_first;
7275 register OP *kid = cLISTOPo->op_first;
7279 if (kid->op_type == OP_PUSHMARK ||
7280 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7282 tokid = &kid->op_sibling;
7283 kid = kid->op_sibling;
7285 if (!kid && PL_opargs[type] & OA_DEFGV)
7286 *tokid = kid = newDEFSVOP();
7290 sibl = kid->op_sibling;
7292 if (!sibl && kid->op_type == OP_STUB) {
7299 /* list seen where single (scalar) arg expected? */
7300 if (numargs == 1 && !(oa >> 4)
7301 && kid->op_type == OP_LIST && type != OP_SCALAR)
7303 return too_many_arguments(o,PL_op_desc[type]);
7316 if ((type == OP_PUSH || type == OP_UNSHIFT)
7317 && !kid->op_sibling)
7318 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7319 "Useless use of %s with no values",
7322 if (kid->op_type == OP_CONST &&
7323 (kid->op_private & OPpCONST_BARE))
7325 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7326 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7327 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7328 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7329 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7331 op_getmad(kid,newop,'K');
7336 kid->op_sibling = sibl;
7339 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7340 bad_type(numargs, "array", PL_op_desc[type], kid);
7344 if (kid->op_type == OP_CONST &&
7345 (kid->op_private & OPpCONST_BARE))
7347 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7348 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7349 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7350 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7351 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7353 op_getmad(kid,newop,'K');
7358 kid->op_sibling = sibl;
7361 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7362 bad_type(numargs, "hash", PL_op_desc[type], kid);
7367 OP * const newop = newUNOP(OP_NULL, 0, kid);
7368 kid->op_sibling = 0;
7370 newop->op_next = newop;
7372 kid->op_sibling = sibl;
7377 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7378 if (kid->op_type == OP_CONST &&
7379 (kid->op_private & OPpCONST_BARE))
7381 OP * const newop = newGVOP(OP_GV, 0,
7382 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7383 if (!(o->op_private & 1) && /* if not unop */
7384 kid == cLISTOPo->op_last)
7385 cLISTOPo->op_last = newop;
7387 op_getmad(kid,newop,'K');
7393 else if (kid->op_type == OP_READLINE) {
7394 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7395 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7398 I32 flags = OPf_SPECIAL;
7402 /* is this op a FH constructor? */
7403 if (is_handle_constructor(o,numargs)) {
7404 const char *name = NULL;
7408 /* Set a flag to tell rv2gv to vivify
7409 * need to "prove" flag does not mean something
7410 * else already - NI-S 1999/05/07
7413 if (kid->op_type == OP_PADSV) {
7415 = PAD_COMPNAME_SV(kid->op_targ);
7416 name = SvPV_const(namesv, len);
7418 else if (kid->op_type == OP_RV2SV
7419 && kUNOP->op_first->op_type == OP_GV)
7421 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7423 len = GvNAMELEN(gv);
7425 else if (kid->op_type == OP_AELEM
7426 || kid->op_type == OP_HELEM)
7429 OP *op = ((BINOP*)kid)->op_first;
7433 const char * const a =
7434 kid->op_type == OP_AELEM ?
7436 if (((op->op_type == OP_RV2AV) ||
7437 (op->op_type == OP_RV2HV)) &&
7438 (firstop = ((UNOP*)op)->op_first) &&
7439 (firstop->op_type == OP_GV)) {
7440 /* packagevar $a[] or $h{} */
7441 GV * const gv = cGVOPx_gv(firstop);
7449 else if (op->op_type == OP_PADAV
7450 || op->op_type == OP_PADHV) {
7451 /* lexicalvar $a[] or $h{} */
7452 const char * const padname =
7453 PAD_COMPNAME_PV(op->op_targ);
7462 name = SvPV_const(tmpstr, len);
7467 name = "__ANONIO__";
7474 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7475 namesv = PAD_SVl(targ);
7476 SvUPGRADE(namesv, SVt_PV);
7478 sv_setpvs(namesv, "$");
7479 sv_catpvn(namesv, name, len);
7482 kid->op_sibling = 0;
7483 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7484 kid->op_targ = targ;
7485 kid->op_private |= priv;
7487 kid->op_sibling = sibl;
7493 mod(scalar(kid), type);
7497 tokid = &kid->op_sibling;
7498 kid = kid->op_sibling;
7501 if (kid && kid->op_type != OP_STUB)
7502 return too_many_arguments(o,OP_DESC(o));
7503 o->op_private |= numargs;
7505 /* FIXME - should the numargs move as for the PERL_MAD case? */
7506 o->op_private |= numargs;
7508 return too_many_arguments(o,OP_DESC(o));
7512 else if (PL_opargs[type] & OA_DEFGV) {
7514 OP *newop = newUNOP(type, 0, newDEFSVOP());
7515 op_getmad(o,newop,'O');
7518 /* Ordering of these two is important to keep f_map.t passing. */
7520 return newUNOP(type, 0, newDEFSVOP());
7525 while (oa & OA_OPTIONAL)
7527 if (oa && oa != OA_LIST)
7528 return too_few_arguments(o,OP_DESC(o));
7534 Perl_ck_glob(pTHX_ OP *o)
7539 PERL_ARGS_ASSERT_CK_GLOB;
7542 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7543 append_elem(OP_GLOB, o, newDEFSVOP());
7545 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7546 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7548 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7551 #if !defined(PERL_EXTERNAL_GLOB)
7552 /* XXX this can be tightened up and made more failsafe. */
7553 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7556 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7557 newSVpvs("File::Glob"), NULL, NULL, NULL);
7558 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7559 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7560 GvCV(gv) = GvCV(glob_gv);
7561 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7562 GvIMPORTED_CV_on(gv);
7566 #endif /* PERL_EXTERNAL_GLOB */
7568 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7569 append_elem(OP_GLOB, o,
7570 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7571 o->op_type = OP_LIST;
7572 o->op_ppaddr = PL_ppaddr[OP_LIST];
7573 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7574 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7575 cLISTOPo->op_first->op_targ = 0;
7576 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7577 append_elem(OP_LIST, o,
7578 scalar(newUNOP(OP_RV2CV, 0,
7579 newGVOP(OP_GV, 0, gv)))));
7580 o = newUNOP(OP_NULL, 0, ck_subr(o));
7581 o->op_targ = OP_GLOB; /* hint at what it used to be */
7584 gv = newGVgen("main");
7586 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7592 Perl_ck_grep(pTHX_ OP *o)
7597 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7600 PERL_ARGS_ASSERT_CK_GREP;
7602 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7603 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7605 if (o->op_flags & OPf_STACKED) {
7608 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7609 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7610 return no_fh_allowed(o);
7611 for (k = kid; k; k = k->op_next) {
7614 NewOp(1101, gwop, 1, LOGOP);
7615 kid->op_next = (OP*)gwop;
7616 o->op_flags &= ~OPf_STACKED;
7618 kid = cLISTOPo->op_first->op_sibling;
7619 if (type == OP_MAPWHILE)
7624 if (PL_parser && PL_parser->error_count)
7626 kid = cLISTOPo->op_first->op_sibling;
7627 if (kid->op_type != OP_NULL)
7628 Perl_croak(aTHX_ "panic: ck_grep");
7629 kid = kUNOP->op_first;
7632 NewOp(1101, gwop, 1, LOGOP);
7633 gwop->op_type = type;
7634 gwop->op_ppaddr = PL_ppaddr[type];
7635 gwop->op_first = listkids(o);
7636 gwop->op_flags |= OPf_KIDS;
7637 gwop->op_other = LINKLIST(kid);
7638 kid->op_next = (OP*)gwop;
7639 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7640 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7641 o->op_private = gwop->op_private = 0;
7642 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7645 o->op_private = gwop->op_private = OPpGREP_LEX;
7646 gwop->op_targ = o->op_targ = offset;
7649 kid = cLISTOPo->op_first->op_sibling;
7650 if (!kid || !kid->op_sibling)
7651 return too_few_arguments(o,OP_DESC(o));
7652 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7653 mod(kid, OP_GREPSTART);
7659 Perl_ck_index(pTHX_ OP *o)
7661 PERL_ARGS_ASSERT_CK_INDEX;
7663 if (o->op_flags & OPf_KIDS) {
7664 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7666 kid = kid->op_sibling; /* get past "big" */
7667 if (kid && kid->op_type == OP_CONST)
7668 fbm_compile(((SVOP*)kid)->op_sv, 0);
7674 Perl_ck_lfun(pTHX_ OP *o)
7676 const OPCODE type = o->op_type;
7678 PERL_ARGS_ASSERT_CK_LFUN;
7680 return modkids(ck_fun(o), type);
7684 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7686 PERL_ARGS_ASSERT_CK_DEFINED;
7688 if ((o->op_flags & OPf_KIDS)) {
7689 switch (cUNOPo->op_first->op_type) {
7691 /* This is needed for
7692 if (defined %stash::)
7693 to work. Do not break Tk.
7695 break; /* Globals via GV can be undef */
7697 case OP_AASSIGN: /* Is this a good idea? */
7698 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7699 "defined(@array) is deprecated");
7700 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7701 "\t(Maybe you should just omit the defined()?)\n");
7705 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7706 "defined(%%hash) is deprecated");
7707 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7708 "\t(Maybe you should just omit the defined()?)\n");
7719 Perl_ck_readline(pTHX_ OP *o)
7721 PERL_ARGS_ASSERT_CK_READLINE;
7723 if (!(o->op_flags & OPf_KIDS)) {
7725 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7727 op_getmad(o,newop,'O');
7737 Perl_ck_rfun(pTHX_ OP *o)
7739 const OPCODE type = o->op_type;
7741 PERL_ARGS_ASSERT_CK_RFUN;
7743 return refkids(ck_fun(o), type);
7747 Perl_ck_listiob(pTHX_ OP *o)
7751 PERL_ARGS_ASSERT_CK_LISTIOB;
7753 kid = cLISTOPo->op_first;
7756 kid = cLISTOPo->op_first;
7758 if (kid->op_type == OP_PUSHMARK)
7759 kid = kid->op_sibling;
7760 if (kid && o->op_flags & OPf_STACKED)
7761 kid = kid->op_sibling;
7762 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7763 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7764 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7765 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7766 cLISTOPo->op_first->op_sibling = kid;
7767 cLISTOPo->op_last = kid;
7768 kid = kid->op_sibling;
7773 append_elem(o->op_type, o, newDEFSVOP());
7779 Perl_ck_smartmatch(pTHX_ OP *o)
7782 if (0 == (o->op_flags & OPf_SPECIAL)) {
7783 OP *first = cBINOPo->op_first;
7784 OP *second = first->op_sibling;
7786 /* Implicitly take a reference to an array or hash */
7787 first->op_sibling = NULL;
7788 first = cBINOPo->op_first = ref_array_or_hash(first);
7789 second = first->op_sibling = ref_array_or_hash(second);
7791 /* Implicitly take a reference to a regular expression */
7792 if (first->op_type == OP_MATCH) {
7793 first->op_type = OP_QR;
7794 first->op_ppaddr = PL_ppaddr[OP_QR];
7796 if (second->op_type == OP_MATCH) {
7797 second->op_type = OP_QR;
7798 second->op_ppaddr = PL_ppaddr[OP_QR];
7807 Perl_ck_sassign(pTHX_ OP *o)
7810 OP * const kid = cLISTOPo->op_first;
7812 PERL_ARGS_ASSERT_CK_SASSIGN;
7814 /* has a disposable target? */
7815 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7816 && !(kid->op_flags & OPf_STACKED)
7817 /* Cannot steal the second time! */
7818 && !(kid->op_private & OPpTARGET_MY)
7819 /* Keep the full thing for madskills */
7823 OP * const kkid = kid->op_sibling;
7825 /* Can just relocate the target. */
7826 if (kkid && kkid->op_type == OP_PADSV
7827 && !(kkid->op_private & OPpLVAL_INTRO))
7829 kid->op_targ = kkid->op_targ;
7831 /* Now we do not need PADSV and SASSIGN. */
7832 kid->op_sibling = o->op_sibling; /* NULL */
7833 cLISTOPo->op_first = NULL;
7836 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7840 if (kid->op_sibling) {
7841 OP *kkid = kid->op_sibling;
7842 if (kkid->op_type == OP_PADSV
7843 && (kkid->op_private & OPpLVAL_INTRO)
7844 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7845 const PADOFFSET target = kkid->op_targ;
7846 OP *const other = newOP(OP_PADSV,
7848 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7849 OP *const first = newOP(OP_NULL, 0);
7850 OP *const nullop = newCONDOP(0, first, o, other);
7851 OP *const condop = first->op_next;
7852 /* hijacking PADSTALE for uninitialized state variables */
7853 SvPADSTALE_on(PAD_SVl(target));
7855 condop->op_type = OP_ONCE;
7856 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7857 condop->op_targ = target;
7858 other->op_targ = target;
7860 /* Because we change the type of the op here, we will skip the
7861 assinment binop->op_last = binop->op_first->op_sibling; at the
7862 end of Perl_newBINOP(). So need to do it here. */
7863 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7872 Perl_ck_match(pTHX_ OP *o)
7876 PERL_ARGS_ASSERT_CK_MATCH;
7878 if (o->op_type != OP_QR && PL_compcv) {
7879 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7880 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7881 o->op_targ = offset;
7882 o->op_private |= OPpTARGET_MY;
7885 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7886 o->op_private |= OPpRUNTIME;
7891 Perl_ck_method(pTHX_ OP *o)
7893 OP * const kid = cUNOPo->op_first;
7895 PERL_ARGS_ASSERT_CK_METHOD;
7897 if (kid->op_type == OP_CONST) {
7898 SV* sv = kSVOP->op_sv;
7899 const char * const method = SvPVX_const(sv);
7900 if (!(strchr(method, ':') || strchr(method, '\''))) {
7902 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7903 sv = newSVpvn_share(method, SvCUR(sv), 0);
7906 kSVOP->op_sv = NULL;
7908 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7910 op_getmad(o,cmop,'O');
7921 Perl_ck_null(pTHX_ OP *o)
7923 PERL_ARGS_ASSERT_CK_NULL;
7924 PERL_UNUSED_CONTEXT;
7929 Perl_ck_open(pTHX_ OP *o)
7932 HV * const table = GvHV(PL_hintgv);
7934 PERL_ARGS_ASSERT_CK_OPEN;
7937 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7940 const char *d = SvPV_const(*svp, len);
7941 const I32 mode = mode_from_discipline(d, len);
7942 if (mode & O_BINARY)
7943 o->op_private |= OPpOPEN_IN_RAW;
7944 else if (mode & O_TEXT)
7945 o->op_private |= OPpOPEN_IN_CRLF;
7948 svp = hv_fetchs(table, "open_OUT", FALSE);
7951 const char *d = SvPV_const(*svp, len);
7952 const I32 mode = mode_from_discipline(d, len);
7953 if (mode & O_BINARY)
7954 o->op_private |= OPpOPEN_OUT_RAW;
7955 else if (mode & O_TEXT)
7956 o->op_private |= OPpOPEN_OUT_CRLF;
7959 if (o->op_type == OP_BACKTICK) {
7960 if (!(o->op_flags & OPf_KIDS)) {
7961 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7963 op_getmad(o,newop,'O');
7972 /* In case of three-arg dup open remove strictness
7973 * from the last arg if it is a bareword. */
7974 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7975 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7979 if ((last->op_type == OP_CONST) && /* The bareword. */
7980 (last->op_private & OPpCONST_BARE) &&
7981 (last->op_private & OPpCONST_STRICT) &&
7982 (oa = first->op_sibling) && /* The fh. */
7983 (oa = oa->op_sibling) && /* The mode. */
7984 (oa->op_type == OP_CONST) &&
7985 SvPOK(((SVOP*)oa)->op_sv) &&
7986 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7987 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7988 (last == oa->op_sibling)) /* The bareword. */
7989 last->op_private &= ~OPpCONST_STRICT;
7995 Perl_ck_repeat(pTHX_ OP *o)
7997 PERL_ARGS_ASSERT_CK_REPEAT;
7999 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8000 o->op_private |= OPpREPEAT_DOLIST;
8001 cBINOPo->op_first = force_list(cBINOPo->op_first);
8009 Perl_ck_require(pTHX_ OP *o)
8014 PERL_ARGS_ASSERT_CK_REQUIRE;
8016 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8017 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8019 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8020 SV * const sv = kid->op_sv;
8021 U32 was_readonly = SvREADONLY(sv);
8028 sv_force_normal_flags(sv, 0);
8029 assert(!SvREADONLY(sv));
8039 for (; s < end; s++) {
8040 if (*s == ':' && s[1] == ':') {
8042 Move(s+2, s+1, end - s - 1, char);
8047 sv_catpvs(sv, ".pm");
8048 SvFLAGS(sv) |= was_readonly;
8052 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8053 /* handle override, if any */
8054 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8055 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8056 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8057 gv = gvp ? *gvp : NULL;
8061 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8062 OP * const kid = cUNOPo->op_first;
8065 cUNOPo->op_first = 0;
8069 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8070 append_elem(OP_LIST, kid,
8071 scalar(newUNOP(OP_RV2CV, 0,
8074 op_getmad(o,newop,'O');
8078 return scalar(ck_fun(o));
8082 Perl_ck_return(pTHX_ OP *o)
8087 PERL_ARGS_ASSERT_CK_RETURN;
8089 kid = cLISTOPo->op_first->op_sibling;
8090 if (CvLVALUE(PL_compcv)) {
8091 for (; kid; kid = kid->op_sibling)
8092 mod(kid, OP_LEAVESUBLV);
8094 for (; kid; kid = kid->op_sibling)
8095 if ((kid->op_type == OP_NULL)
8096 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8097 /* This is a do block */
8098 OP *op = kUNOP->op_first;
8099 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8100 op = cUNOPx(op)->op_first;
8101 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8102 /* Force the use of the caller's context */
8103 op->op_flags |= OPf_SPECIAL;
8112 Perl_ck_select(pTHX_ OP *o)
8117 PERL_ARGS_ASSERT_CK_SELECT;
8119 if (o->op_flags & OPf_KIDS) {
8120 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8121 if (kid && kid->op_sibling) {
8122 o->op_type = OP_SSELECT;
8123 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8125 return fold_constants(o);
8129 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8130 if (kid && kid->op_type == OP_RV2GV)
8131 kid->op_private &= ~HINT_STRICT_REFS;
8136 Perl_ck_shift(pTHX_ OP *o)
8139 const I32 type = o->op_type;
8141 PERL_ARGS_ASSERT_CK_SHIFT;
8143 if (!(o->op_flags & OPf_KIDS)) {
8146 if (!CvUNIQUE(PL_compcv)) {
8147 o->op_flags |= OPf_SPECIAL;
8151 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8154 OP * const oldo = o;
8155 o = newUNOP(type, 0, scalar(argop));
8156 op_getmad(oldo,o,'O');
8161 return newUNOP(type, 0, scalar(argop));
8164 return scalar(modkids(ck_fun(o), type));
8168 Perl_ck_sort(pTHX_ OP *o)
8173 PERL_ARGS_ASSERT_CK_SORT;
8175 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8176 HV * const hinthv = GvHV(PL_hintgv);
8178 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8180 const I32 sorthints = (I32)SvIV(*svp);
8181 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8182 o->op_private |= OPpSORT_QSORT;
8183 if ((sorthints & HINT_SORT_STABLE) != 0)
8184 o->op_private |= OPpSORT_STABLE;
8189 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8191 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8192 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8194 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8196 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8198 if (kid->op_type == OP_SCOPE) {
8202 else if (kid->op_type == OP_LEAVE) {
8203 if (o->op_type == OP_SORT) {
8204 op_null(kid); /* wipe out leave */
8207 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8208 if (k->op_next == kid)
8210 /* don't descend into loops */
8211 else if (k->op_type == OP_ENTERLOOP
8212 || k->op_type == OP_ENTERITER)
8214 k = cLOOPx(k)->op_lastop;
8219 kid->op_next = 0; /* just disconnect the leave */
8220 k = kLISTOP->op_first;
8225 if (o->op_type == OP_SORT) {
8226 /* provide scalar context for comparison function/block */
8232 o->op_flags |= OPf_SPECIAL;
8234 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8237 firstkid = firstkid->op_sibling;
8240 /* provide list context for arguments */
8241 if (o->op_type == OP_SORT)
8248 S_simplify_sort(pTHX_ OP *o)
8251 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8257 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8259 if (!(o->op_flags & OPf_STACKED))
8261 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8262 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8263 kid = kUNOP->op_first; /* get past null */
8264 if (kid->op_type != OP_SCOPE)
8266 kid = kLISTOP->op_last; /* get past scope */
8267 switch(kid->op_type) {
8275 k = kid; /* remember this node*/
8276 if (kBINOP->op_first->op_type != OP_RV2SV)
8278 kid = kBINOP->op_first; /* get past cmp */
8279 if (kUNOP->op_first->op_type != OP_GV)
8281 kid = kUNOP->op_first; /* get past rv2sv */
8283 if (GvSTASH(gv) != PL_curstash)
8285 gvname = GvNAME(gv);
8286 if (*gvname == 'a' && gvname[1] == '\0')
8288 else if (*gvname == 'b' && gvname[1] == '\0')
8293 kid = k; /* back to cmp */
8294 if (kBINOP->op_last->op_type != OP_RV2SV)
8296 kid = kBINOP->op_last; /* down to 2nd arg */
8297 if (kUNOP->op_first->op_type != OP_GV)
8299 kid = kUNOP->op_first; /* get past rv2sv */
8301 if (GvSTASH(gv) != PL_curstash)
8303 gvname = GvNAME(gv);
8305 ? !(*gvname == 'a' && gvname[1] == '\0')
8306 : !(*gvname == 'b' && gvname[1] == '\0'))
8308 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8310 o->op_private |= OPpSORT_DESCEND;
8311 if (k->op_type == OP_NCMP)
8312 o->op_private |= OPpSORT_NUMERIC;
8313 if (k->op_type == OP_I_NCMP)
8314 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8315 kid = cLISTOPo->op_first->op_sibling;
8316 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8318 op_getmad(kid,o,'S'); /* then delete it */
8320 op_free(kid); /* then delete it */
8325 Perl_ck_split(pTHX_ OP *o)
8330 PERL_ARGS_ASSERT_CK_SPLIT;
8332 if (o->op_flags & OPf_STACKED)
8333 return no_fh_allowed(o);
8335 kid = cLISTOPo->op_first;
8336 if (kid->op_type != OP_NULL)
8337 Perl_croak(aTHX_ "panic: ck_split");
8338 kid = kid->op_sibling;
8339 op_free(cLISTOPo->op_first);
8340 cLISTOPo->op_first = kid;
8342 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8343 cLISTOPo->op_last = kid; /* There was only one element previously */
8346 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8347 OP * const sibl = kid->op_sibling;
8348 kid->op_sibling = 0;
8349 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8350 if (cLISTOPo->op_first == cLISTOPo->op_last)
8351 cLISTOPo->op_last = kid;
8352 cLISTOPo->op_first = kid;
8353 kid->op_sibling = sibl;
8356 kid->op_type = OP_PUSHRE;
8357 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8359 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8360 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8361 "Use of /g modifier is meaningless in split");
8364 if (!kid->op_sibling)
8365 append_elem(OP_SPLIT, o, newDEFSVOP());
8367 kid = kid->op_sibling;
8370 if (!kid->op_sibling)
8371 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8372 assert(kid->op_sibling);
8374 kid = kid->op_sibling;
8377 if (kid->op_sibling)
8378 return too_many_arguments(o,OP_DESC(o));
8384 Perl_ck_join(pTHX_ OP *o)
8386 const OP * const kid = cLISTOPo->op_first->op_sibling;
8388 PERL_ARGS_ASSERT_CK_JOIN;
8390 if (kid && kid->op_type == OP_MATCH) {
8391 if (ckWARN(WARN_SYNTAX)) {
8392 const REGEXP *re = PM_GETRE(kPMOP);
8393 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8394 const STRLEN len = re ? RX_PRELEN(re) : 6;
8395 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8396 "/%.*s/ should probably be written as \"%.*s\"",
8397 (int)len, pmstr, (int)len, pmstr);
8404 Perl_ck_subr(pTHX_ OP *o)
8407 OP *prev = ((cUNOPo->op_first->op_sibling)
8408 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8409 OP *o2 = prev->op_sibling;
8411 const char *proto = NULL;
8412 const char *proto_end = NULL;
8417 I32 contextclass = 0;
8418 const char *e = NULL;
8420 PERL_ARGS_ASSERT_CK_SUBR;
8422 o->op_private |= OPpENTERSUB_HASTARG;
8423 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8424 if (PERLDB_SUB && PL_curstash != PL_debstash)
8425 o->op_private |= OPpENTERSUB_DB;
8427 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8428 if (cvop->op_type == OP_RV2CV) {
8429 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8430 op_null(cvop); /* disable rv2cv */
8431 if (!(o->op_private & OPpENTERSUB_AMPER)) {
8432 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8434 switch (tmpop->op_type) {
8436 gv = cGVOPx_gv(tmpop);
8439 tmpop->op_private |= OPpEARLY_CV;
8442 SV *sv = cSVOPx_sv(tmpop);
8443 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8447 if (cv && SvPOK(cv)) {
8449 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8450 proto = SvPV(MUTABLE_SV(cv), len);
8451 proto_end = proto + len;
8455 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8456 if (o2->op_type == OP_CONST)
8457 o2->op_private &= ~OPpCONST_STRICT;
8458 else if (o2->op_type == OP_LIST) {
8459 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8460 if (sib && sib->op_type == OP_CONST)
8461 sib->op_private &= ~OPpCONST_STRICT;
8466 while (o2 != cvop) {
8467 if (PL_madskills && o2->op_type == OP_STUB) {
8468 o2 = o2->op_sibling;
8472 /* Yes, this while loop is duplicated. But it's a lot clearer
8473 to see what is going on without that massive switch(*proto)
8476 list(o2); /* This is only called if !proto */
8478 mod(o2, OP_ENTERSUB);
8479 o2 = o2->op_sibling;
8482 while (o2 != cvop) {
8484 if (PL_madskills && o2->op_type == OP_STUB) {
8485 o2 = o2->op_sibling;
8488 if (PL_madskills && o2->op_type == OP_NULL)
8489 o3 = ((UNOP*)o2)->op_first;
8493 if (proto >= proto_end)
8494 return too_many_arguments(o, gv_ename(namegv));
8502 /* _ must be at the end */
8503 if (proto[1] && proto[1] != ';')
8518 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8520 arg == 1 ? "block or sub {}" : "sub {}",
8521 gv_ename(namegv), o3);
8524 /* '*' allows any scalar type, including bareword */
8527 if (o3->op_type == OP_RV2GV)
8528 goto wrapref; /* autoconvert GLOB -> GLOBref */
8529 else if (o3->op_type == OP_CONST)
8530 o3->op_private &= ~OPpCONST_STRICT;
8531 else if (o3->op_type == OP_ENTERSUB) {
8532 /* accidental subroutine, revert to bareword */
8533 OP *gvop = ((UNOP*)o3)->op_first;
8534 if (gvop && gvop->op_type == OP_NULL) {
8535 gvop = ((UNOP*)gvop)->op_first;
8537 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8540 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8541 (gvop = ((UNOP*)gvop)->op_first) &&
8542 gvop->op_type == OP_GV)
8544 GV * const gv = cGVOPx_gv(gvop);
8545 OP * const sibling = o2->op_sibling;
8546 SV * const n = newSVpvs("");
8548 OP * const oldo2 = o2;
8552 gv_fullname4(n, gv, "", FALSE);
8553 o2 = newSVOP(OP_CONST, 0, n);
8554 op_getmad(oldo2,o2,'O');
8555 prev->op_sibling = o2;
8556 o2->op_sibling = sibling;
8572 if (contextclass++ == 0) {
8573 e = strchr(proto, ']');
8574 if (!e || e == proto)
8583 const char *p = proto;
8584 const char *const end = proto;
8586 while (*--p != '[') {}
8587 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8589 gv_ename(namegv), o3);
8594 if (o3->op_type == OP_RV2GV)
8597 bad_type(arg, "symbol", gv_ename(namegv), o3);
8600 if (o3->op_type == OP_ENTERSUB)
8603 bad_type(arg, "subroutine entry", gv_ename(namegv),
8607 if (o3->op_type == OP_RV2SV ||
8608 o3->op_type == OP_PADSV ||
8609 o3->op_type == OP_HELEM ||
8610 o3->op_type == OP_AELEM)
8613 bad_type(arg, "scalar", gv_ename(namegv), o3);
8616 if (o3->op_type == OP_RV2AV ||
8617 o3->op_type == OP_PADAV)
8620 bad_type(arg, "array", gv_ename(namegv), o3);
8623 if (o3->op_type == OP_RV2HV ||
8624 o3->op_type == OP_PADHV)
8627 bad_type(arg, "hash", gv_ename(namegv), o3);
8632 OP* const sib = kid->op_sibling;
8633 kid->op_sibling = 0;
8634 o2 = newUNOP(OP_REFGEN, 0, kid);
8635 o2->op_sibling = sib;
8636 prev->op_sibling = o2;
8638 if (contextclass && e) {
8653 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8654 gv_ename(namegv), SVfARG(cv));
8657 mod(o2, OP_ENTERSUB);
8659 o2 = o2->op_sibling;
8662 if (o2 == cvop && *proto == '_') {
8663 /* generate an access to $_ */
8665 o2->op_sibling = prev->op_sibling;
8666 prev->op_sibling = o2; /* instead of cvop */
8668 if (!optional && proto_end > proto &&
8669 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8670 return too_few_arguments(o, gv_ename(namegv));
8676 Perl_ck_svconst(pTHX_ OP *o)
8678 PERL_ARGS_ASSERT_CK_SVCONST;
8679 PERL_UNUSED_CONTEXT;
8680 SvREADONLY_on(cSVOPo->op_sv);
8685 Perl_ck_chdir(pTHX_ OP *o)
8687 if (o->op_flags & OPf_KIDS) {
8688 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8690 if (kid && kid->op_type == OP_CONST &&
8691 (kid->op_private & OPpCONST_BARE))
8693 o->op_flags |= OPf_SPECIAL;
8694 kid->op_private &= ~OPpCONST_STRICT;
8701 Perl_ck_trunc(pTHX_ OP *o)
8703 PERL_ARGS_ASSERT_CK_TRUNC;
8705 if (o->op_flags & OPf_KIDS) {
8706 SVOP *kid = (SVOP*)cUNOPo->op_first;
8708 if (kid->op_type == OP_NULL)
8709 kid = (SVOP*)kid->op_sibling;
8710 if (kid && kid->op_type == OP_CONST &&
8711 (kid->op_private & OPpCONST_BARE))
8713 o->op_flags |= OPf_SPECIAL;
8714 kid->op_private &= ~OPpCONST_STRICT;
8721 Perl_ck_unpack(pTHX_ OP *o)
8723 OP *kid = cLISTOPo->op_first;
8725 PERL_ARGS_ASSERT_CK_UNPACK;
8727 if (kid->op_sibling) {
8728 kid = kid->op_sibling;
8729 if (!kid->op_sibling)
8730 kid->op_sibling = newDEFSVOP();
8736 Perl_ck_substr(pTHX_ OP *o)
8738 PERL_ARGS_ASSERT_CK_SUBSTR;
8741 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8742 OP *kid = cLISTOPo->op_first;
8744 if (kid->op_type == OP_NULL)
8745 kid = kid->op_sibling;
8747 kid->op_flags |= OPf_MOD;
8754 Perl_ck_each(pTHX_ OP *o)
8757 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8759 PERL_ARGS_ASSERT_CK_EACH;
8762 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8763 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8764 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8765 o->op_type = new_type;
8766 o->op_ppaddr = PL_ppaddr[new_type];
8768 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8769 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8771 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8778 /* caller is supposed to assign the return to the
8779 container of the rep_op var */
8781 S_opt_scalarhv(pTHX_ OP *rep_op) {
8785 PERL_ARGS_ASSERT_OPT_SCALARHV;
8787 NewOp(1101, unop, 1, UNOP);
8788 unop->op_type = (OPCODE)OP_BOOLKEYS;
8789 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8790 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8791 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8792 unop->op_first = rep_op;
8793 unop->op_next = rep_op->op_next;
8794 rep_op->op_next = (OP*)unop;
8795 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8796 unop->op_sibling = rep_op->op_sibling;
8797 rep_op->op_sibling = NULL;
8798 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8799 if (rep_op->op_type == OP_PADHV) {
8800 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8801 rep_op->op_flags |= OPf_WANT_LIST;
8806 /* Checks if o acts as an in-place operator on an array. oright points to the
8807 * beginning of the right-hand side. Returns the left-hand side of the
8808 * assignment if o acts in-place, or NULL otherwise. */
8811 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8815 PERL_ARGS_ASSERT_IS_INPLACE_AV;
8818 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8819 || oright->op_next != o
8820 || (oright->op_private & OPpLVAL_INTRO)
8824 /* o2 follows the chain of op_nexts through the LHS of the
8825 * assign (if any) to the aassign op itself */
8827 if (!o2 || o2->op_type != OP_NULL)
8830 if (!o2 || o2->op_type != OP_PUSHMARK)
8833 if (o2 && o2->op_type == OP_GV)
8836 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8837 || (o2->op_private & OPpLVAL_INTRO)
8842 if (!o2 || o2->op_type != OP_NULL)
8845 if (!o2 || o2->op_type != OP_AASSIGN
8846 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8849 /* check that the sort is the first arg on RHS of assign */
8851 o2 = cUNOPx(o2)->op_first;
8852 if (!o2 || o2->op_type != OP_NULL)
8854 o2 = cUNOPx(o2)->op_first;
8855 if (!o2 || o2->op_type != OP_PUSHMARK)
8857 if (o2->op_sibling != o)
8860 /* check the array is the same on both sides */
8861 if (oleft->op_type == OP_RV2AV) {
8862 if (oright->op_type != OP_RV2AV
8863 || !cUNOPx(oright)->op_first
8864 || cUNOPx(oright)->op_first->op_type != OP_GV
8865 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8866 cGVOPx_gv(cUNOPx(oright)->op_first)
8870 else if (oright->op_type != OP_PADAV
8871 || oright->op_targ != oleft->op_targ
8878 /* A peephole optimizer. We visit the ops in the order they're to execute.
8879 * See the comments at the top of this file for more details about when
8880 * peep() is called */
8883 Perl_rpeep(pTHX_ register OP *o)
8886 register OP* oldop = NULL;
8888 if (!o || o->op_opt)
8892 SAVEVPTR(PL_curcop);
8893 for (; o; o = o->op_next) {
8896 /* By default, this op has now been optimised. A couple of cases below
8897 clear this again. */
8900 switch (o->op_type) {
8902 PL_curcop = ((COP*)o); /* for warnings */
8905 PL_curcop = ((COP*)o); /* for warnings */
8907 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
8908 to carry two labels. For now, take the easier option, and skip
8909 this optimisation if the first NEXTSTATE has a label. */
8910 if (!CopLABEL((COP*)o)) {
8911 OP *nextop = o->op_next;
8912 while (nextop && nextop->op_type == OP_NULL)
8913 nextop = nextop->op_next;
8915 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
8916 COP *firstcop = (COP *)o;
8917 COP *secondcop = (COP *)nextop;
8918 /* We want the COP pointed to by o (and anything else) to
8919 become the next COP down the line. */
8922 firstcop->op_next = secondcop->op_next;
8924 /* Now steal all its pointers, and duplicate the other
8926 firstcop->cop_line = secondcop->cop_line;
8928 firstcop->cop_stashpv = secondcop->cop_stashpv;
8929 firstcop->cop_file = secondcop->cop_file;
8931 firstcop->cop_stash = secondcop->cop_stash;
8932 firstcop->cop_filegv = secondcop->cop_filegv;
8934 firstcop->cop_hints = secondcop->cop_hints;
8935 firstcop->cop_seq = secondcop->cop_seq;
8936 firstcop->cop_warnings = secondcop->cop_warnings;
8937 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
8940 secondcop->cop_stashpv = NULL;
8941 secondcop->cop_file = NULL;
8943 secondcop->cop_stash = NULL;
8944 secondcop->cop_filegv = NULL;
8946 secondcop->cop_warnings = NULL;
8947 secondcop->cop_hints_hash = NULL;
8949 /* If we use op_null(), and hence leave an ex-COP, some
8950 warnings are misreported. For example, the compile-time
8951 error in 'use strict; no strict refs;' */
8952 secondcop->op_type = OP_NULL;
8953 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
8959 if (cSVOPo->op_private & OPpCONST_STRICT)
8960 no_bareword_allowed(o);
8963 case OP_METHOD_NAMED:
8964 /* Relocate sv to the pad for thread safety.
8965 * Despite being a "constant", the SV is written to,
8966 * for reference counts, sv_upgrade() etc. */
8968 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8969 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8970 /* If op_sv is already a PADTMP then it is being used by
8971 * some pad, so make a copy. */
8972 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8973 SvREADONLY_on(PAD_SVl(ix));
8974 SvREFCNT_dec(cSVOPo->op_sv);
8976 else if (o->op_type != OP_METHOD_NAMED
8977 && cSVOPo->op_sv == &PL_sv_undef) {
8978 /* PL_sv_undef is hack - it's unsafe to store it in the
8979 AV that is the pad, because av_fetch treats values of
8980 PL_sv_undef as a "free" AV entry and will merrily
8981 replace them with a new SV, causing pad_alloc to think
8982 that this pad slot is free. (When, clearly, it is not)
8984 SvOK_off(PAD_SVl(ix));
8985 SvPADTMP_on(PAD_SVl(ix));
8986 SvREADONLY_on(PAD_SVl(ix));
8989 SvREFCNT_dec(PAD_SVl(ix));
8990 SvPADTMP_on(cSVOPo->op_sv);
8991 PAD_SETSV(ix, cSVOPo->op_sv);
8992 /* XXX I don't know how this isn't readonly already. */
8993 SvREADONLY_on(PAD_SVl(ix));
8995 cSVOPo->op_sv = NULL;
9002 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9003 if (o->op_next->op_private & OPpTARGET_MY) {
9004 if (o->op_flags & OPf_STACKED) /* chained concats */
9005 break; /* ignore_optimization */
9007 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9008 o->op_targ = o->op_next->op_targ;
9009 o->op_next->op_targ = 0;
9010 o->op_private |= OPpTARGET_MY;
9013 op_null(o->op_next);
9017 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9018 break; /* Scalar stub must produce undef. List stub is noop */
9022 if (o->op_targ == OP_NEXTSTATE
9023 || o->op_targ == OP_DBSTATE)
9025 PL_curcop = ((COP*)o);
9027 /* XXX: We avoid setting op_seq here to prevent later calls
9028 to rpeep() from mistakenly concluding that optimisation
9029 has already occurred. This doesn't fix the real problem,
9030 though (See 20010220.007). AMS 20010719 */
9031 /* op_seq functionality is now replaced by op_opt */
9038 if (oldop && o->op_next) {
9039 oldop->op_next = o->op_next;
9047 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9048 OP* const pop = (o->op_type == OP_PADAV) ?
9049 o->op_next : o->op_next->op_next;
9051 if (pop && pop->op_type == OP_CONST &&
9052 ((PL_op = pop->op_next)) &&
9053 pop->op_next->op_type == OP_AELEM &&
9054 !(pop->op_next->op_private &
9055 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9056 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9061 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9062 no_bareword_allowed(pop);
9063 if (o->op_type == OP_GV)
9064 op_null(o->op_next);
9065 op_null(pop->op_next);
9067 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9068 o->op_next = pop->op_next->op_next;
9069 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9070 o->op_private = (U8)i;
9071 if (o->op_type == OP_GV) {
9076 o->op_flags |= OPf_SPECIAL;
9077 o->op_type = OP_AELEMFAST;
9082 if (o->op_next->op_type == OP_RV2SV) {
9083 if (!(o->op_next->op_private & OPpDEREF)) {
9084 op_null(o->op_next);
9085 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9087 o->op_next = o->op_next->op_next;
9088 o->op_type = OP_GVSV;
9089 o->op_ppaddr = PL_ppaddr[OP_GVSV];
9092 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9093 GV * const gv = cGVOPo_gv;
9094 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9095 /* XXX could check prototype here instead of just carping */
9096 SV * const sv = sv_newmortal();
9097 gv_efullname3(sv, gv, NULL);
9098 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9099 "%"SVf"() called too early to check prototype",
9103 else if (o->op_next->op_type == OP_READLINE
9104 && o->op_next->op_next->op_type == OP_CONCAT
9105 && (o->op_next->op_next->op_flags & OPf_STACKED))
9107 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9108 o->op_type = OP_RCATLINE;
9109 o->op_flags |= OPf_STACKED;
9110 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9111 op_null(o->op_next->op_next);
9112 op_null(o->op_next);
9122 fop = cUNOP->op_first;
9130 fop = cLOGOP->op_first;
9131 sop = fop->op_sibling;
9132 while (cLOGOP->op_other->op_type == OP_NULL)
9133 cLOGOP->op_other = cLOGOP->op_other->op_next;
9134 CALL_RPEEP(cLOGOP->op_other);
9138 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9140 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9145 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9146 while (nop && nop->op_next) {
9147 switch (nop->op_next->op_type) {
9152 lop = nop = nop->op_next;
9163 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9164 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9165 cLOGOP->op_first = opt_scalarhv(fop);
9166 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9167 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9183 while (cLOGOP->op_other->op_type == OP_NULL)
9184 cLOGOP->op_other = cLOGOP->op_other->op_next;
9185 CALL_RPEEP(cLOGOP->op_other);
9190 while (cLOOP->op_redoop->op_type == OP_NULL)
9191 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9192 CALL_RPEEP(cLOOP->op_redoop);
9193 while (cLOOP->op_nextop->op_type == OP_NULL)
9194 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9195 CALL_RPEEP(cLOOP->op_nextop);
9196 while (cLOOP->op_lastop->op_type == OP_NULL)
9197 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9198 CALL_RPEEP(cLOOP->op_lastop);
9202 assert(!(cPMOP->op_pmflags & PMf_ONCE));
9203 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9204 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9205 cPMOP->op_pmstashstartu.op_pmreplstart
9206 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9207 CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9211 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9212 && ckWARN(WARN_SYNTAX))
9214 if (o->op_next->op_sibling) {
9215 const OPCODE type = o->op_next->op_sibling->op_type;
9216 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9217 const line_t oldline = CopLINE(PL_curcop);
9218 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9219 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9220 "Statement unlikely to be reached");
9221 Perl_warner(aTHX_ packWARN(WARN_EXEC),
9222 "\t(Maybe you meant system() when you said exec()?)\n");
9223 CopLINE_set(PL_curcop, oldline);
9234 const char *key = NULL;
9237 if (((BINOP*)o)->op_last->op_type != OP_CONST)
9240 /* Make the CONST have a shared SV */
9241 svp = cSVOPx_svp(((BINOP*)o)->op_last);
9242 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9243 key = SvPV_const(sv, keylen);
9244 lexname = newSVpvn_share(key,
9245 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9251 if ((o->op_private & (OPpLVAL_INTRO)))
9254 rop = (UNOP*)((BINOP*)o)->op_first;
9255 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9257 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9258 if (!SvPAD_TYPED(lexname))
9260 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9261 if (!fields || !GvHV(*fields))
9263 key = SvPV_const(*svp, keylen);
9264 if (!hv_fetch(GvHV(*fields), key,
9265 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9267 Perl_croak(aTHX_ "No such class field \"%s\" "
9268 "in variable %s of type %s",
9269 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9282 SVOP *first_key_op, *key_op;
9284 if ((o->op_private & (OPpLVAL_INTRO))
9285 /* I bet there's always a pushmark... */
9286 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9287 /* hmmm, no optimization if list contains only one key. */
9289 rop = (UNOP*)((LISTOP*)o)->op_last;
9290 if (rop->op_type != OP_RV2HV)
9292 if (rop->op_first->op_type == OP_PADSV)
9293 /* @$hash{qw(keys here)} */
9294 rop = (UNOP*)rop->op_first;
9296 /* @{$hash}{qw(keys here)} */
9297 if (rop->op_first->op_type == OP_SCOPE
9298 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9300 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9306 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9307 if (!SvPAD_TYPED(lexname))
9309 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9310 if (!fields || !GvHV(*fields))
9312 /* Again guessing that the pushmark can be jumped over.... */
9313 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9314 ->op_first->op_sibling;
9315 for (key_op = first_key_op; key_op;
9316 key_op = (SVOP*)key_op->op_sibling) {
9317 if (key_op->op_type != OP_CONST)
9319 svp = cSVOPx_svp(key_op);
9320 key = SvPV_const(*svp, keylen);
9321 if (!hv_fetch(GvHV(*fields), key,
9322 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9324 Perl_croak(aTHX_ "No such class field \"%s\" "
9325 "in variable %s of type %s",
9326 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9335 && ( oldop->op_type == OP_AELEM
9336 || oldop->op_type == OP_PADSV
9337 || oldop->op_type == OP_RV2SV
9338 || oldop->op_type == OP_RV2GV
9339 || oldop->op_type == OP_HELEM
9341 && (oldop->op_private & OPpDEREF)
9343 o->op_private |= OPpDEREFed;
9347 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9351 /* check that RHS of sort is a single plain array */
9352 OP *oright = cUNOPo->op_first;
9353 if (!oright || oright->op_type != OP_PUSHMARK)
9356 /* reverse sort ... can be optimised. */
9357 if (!cUNOPo->op_sibling) {
9358 /* Nothing follows us on the list. */
9359 OP * const reverse = o->op_next;
9361 if (reverse->op_type == OP_REVERSE &&
9362 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9363 OP * const pushmark = cUNOPx(reverse)->op_first;
9364 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9365 && (cUNOPx(pushmark)->op_sibling == o)) {
9366 /* reverse -> pushmark -> sort */
9367 o->op_private |= OPpSORT_REVERSE;
9369 pushmark->op_next = oright->op_next;
9375 /* make @a = sort @a act in-place */
9377 oright = cUNOPx(oright)->op_sibling;
9380 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9381 oright = cUNOPx(oright)->op_sibling;
9384 oleft = is_inplace_av(o, oright);
9388 /* transfer MODishness etc from LHS arg to RHS arg */
9389 oright->op_flags = oleft->op_flags;
9390 o->op_private |= OPpSORT_INPLACE;
9392 /* excise push->gv->rv2av->null->aassign */
9393 o2 = o->op_next->op_next;
9394 op_null(o2); /* PUSHMARK */
9396 if (o2->op_type == OP_GV) {
9397 op_null(o2); /* GV */
9400 op_null(o2); /* RV2AV or PADAV */
9401 o2 = o2->op_next->op_next;
9402 op_null(o2); /* AASSIGN */
9404 o->op_next = o2->op_next;
9410 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9413 LISTOP *enter, *exlist;
9415 /* @a = reverse @a */
9416 if ((oright = cLISTOPo->op_first)
9417 && (oright->op_type == OP_PUSHMARK)
9418 && (oright = oright->op_sibling)
9419 && (oleft = is_inplace_av(o, oright))) {
9422 /* transfer MODishness etc from LHS arg to RHS arg */
9423 oright->op_flags = oleft->op_flags;
9424 o->op_private |= OPpREVERSE_INPLACE;
9426 /* excise push->gv->rv2av->null->aassign */
9427 o2 = o->op_next->op_next;
9428 op_null(o2); /* PUSHMARK */
9430 if (o2->op_type == OP_GV) {
9431 op_null(o2); /* GV */
9434 op_null(o2); /* RV2AV or PADAV */
9435 o2 = o2->op_next->op_next;
9436 op_null(o2); /* AASSIGN */
9438 o->op_next = o2->op_next;
9442 enter = (LISTOP *) o->op_next;
9445 if (enter->op_type == OP_NULL) {
9446 enter = (LISTOP *) enter->op_next;
9450 /* for $a (...) will have OP_GV then OP_RV2GV here.
9451 for (...) just has an OP_GV. */
9452 if (enter->op_type == OP_GV) {
9453 gvop = (OP *) enter;
9454 enter = (LISTOP *) enter->op_next;
9457 if (enter->op_type == OP_RV2GV) {
9458 enter = (LISTOP *) enter->op_next;
9464 if (enter->op_type != OP_ENTERITER)
9467 iter = enter->op_next;
9468 if (!iter || iter->op_type != OP_ITER)
9471 expushmark = enter->op_first;
9472 if (!expushmark || expushmark->op_type != OP_NULL
9473 || expushmark->op_targ != OP_PUSHMARK)
9476 exlist = (LISTOP *) expushmark->op_sibling;
9477 if (!exlist || exlist->op_type != OP_NULL
9478 || exlist->op_targ != OP_LIST)
9481 if (exlist->op_last != o) {
9482 /* Mmm. Was expecting to point back to this op. */
9485 theirmark = exlist->op_first;
9486 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9489 if (theirmark->op_sibling != o) {
9490 /* There's something between the mark and the reverse, eg
9491 for (1, reverse (...))
9496 ourmark = ((LISTOP *)o)->op_first;
9497 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9500 ourlast = ((LISTOP *)o)->op_last;
9501 if (!ourlast || ourlast->op_next != o)
9504 rv2av = ourmark->op_sibling;
9505 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9506 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9507 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9508 /* We're just reversing a single array. */
9509 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9510 enter->op_flags |= OPf_STACKED;
9513 /* We don't have control over who points to theirmark, so sacrifice
9515 theirmark->op_next = ourmark->op_next;
9516 theirmark->op_flags = ourmark->op_flags;
9517 ourlast->op_next = gvop ? gvop : (OP *) enter;
9520 enter->op_private |= OPpITER_REVERSED;
9521 iter->op_private |= OPpITER_REVERSED;
9528 UNOP *refgen, *rv2cv;
9531 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9534 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9537 rv2gv = ((BINOP *)o)->op_last;
9538 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9541 refgen = (UNOP *)((BINOP *)o)->op_first;
9543 if (!refgen || refgen->op_type != OP_REFGEN)
9546 exlist = (LISTOP *)refgen->op_first;
9547 if (!exlist || exlist->op_type != OP_NULL
9548 || exlist->op_targ != OP_LIST)
9551 if (exlist->op_first->op_type != OP_PUSHMARK)
9554 rv2cv = (UNOP*)exlist->op_last;
9556 if (rv2cv->op_type != OP_RV2CV)
9559 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9560 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9561 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9563 o->op_private |= OPpASSIGN_CV_TO_GV;
9564 rv2gv->op_private |= OPpDONT_INIT_GV;
9565 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9573 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9574 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9584 Perl_peep(pTHX_ register OP *o)
9590 Perl_custom_op_name(pTHX_ const OP* o)
9593 const IV index = PTR2IV(o->op_ppaddr);
9597 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9599 if (!PL_custom_op_names) /* This probably shouldn't happen */
9600 return (char *)PL_op_name[OP_CUSTOM];
9602 keysv = sv_2mortal(newSViv(index));
9604 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9606 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9608 return SvPV_nolen(HeVAL(he));
9612 Perl_custom_op_desc(pTHX_ const OP* o)
9615 const IV index = PTR2IV(o->op_ppaddr);
9619 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9621 if (!PL_custom_op_descs)
9622 return (char *)PL_op_desc[OP_CUSTOM];
9624 keysv = sv_2mortal(newSViv(index));
9626 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9628 return (char *)PL_op_desc[OP_CUSTOM];
9630 return SvPV_nolen(HeVAL(he));
9635 /* Efficient sub that returns a constant scalar value. */
9637 const_sv_xsub(pTHX_ CV* cv)
9641 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9645 /* diag_listed_as: SKIPME */
9646 Perl_croak(aTHX_ "usage: %s::%s()",
9647 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9660 * c-indentation-style: bsd
9662 * indent-tabs-mode: t
9665 * ex: set ts=8 sts=4 sw=4 noet: